packages feed

GLUT 2.5.1.1 → 2.6.0.0

raw patch · 57 files changed

+6321/−6323 lines, 57 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

- Graphics.UI.GLUT.Begin: ContinueExectuion :: ActionOnWindowClose

Files

GLUT.cabal view
@@ -1,19 +1,20 @@ name: GLUT-version: 2.5.1.1+version: 2.6.0.0+synopsis: A binding for the OpenGL Utility Toolkit+description:+  A Haskell binding for the OpenGL Utility Toolkit, a window system independent+  toolkit for writing OpenGL programs. For more information about the C library+  on which this binding is based, please see:+  <http://www.opengl.org/resources/libraries/glut/>.+homepage: http://www.haskell.org/haskellwiki/Opengl+bug-reports: https://github.com/haskell-opengl/GLUT/issues license: BSD3 license-file: LICENSE+author: Sven Panne maintainer: Sven Panne <svenpanne@gmail.com>, Jason Dagit <dagitj@gmail.com>-bug-reports: https://github.com/haskell-opengl/GLUT/issues-homepage: http://www.haskell.org/haskellwiki/Opengl category: Graphics-synopsis: A binding for the OpenGL Utility Toolkit-description:-   A Haskell binding for the OpenGL Utility Toolkit, a window system independent-   toolkit for writing OpenGL programs. For more information about the C library-   on which this binding is based, please see:-   <http://www.opengl.org/resources/libraries/glut/>. build-type: Simple-cabal-version: >=1.6+cabal-version: >=1.10 extra-source-files:    README.md    examples/00-README@@ -138,58 +139,61 @@    include/HsGLUTExt.h  flag UseNativeWindowsLibraries-   description:-      When compiling under Windows, use the native libraries instead of e.g. the-      ones coming with Cygwin.+  description:+    When compiling under Windows, use the native libraries instead of e.g. the+    ones coming with Cygwin.  library-   exposed-modules:-      Graphics.UI.GLUT,-      Graphics.UI.GLUT.Begin,-      Graphics.UI.GLUT.Callbacks,-      Graphics.UI.GLUT.Callbacks.Global,-      Graphics.UI.GLUT.Callbacks.Window,-      Graphics.UI.GLUT.Colormap,-      Graphics.UI.GLUT.Debugging,-      Graphics.UI.GLUT.DeviceControl,-      Graphics.UI.GLUT.Fonts,-      Graphics.UI.GLUT.GameMode,-      Graphics.UI.GLUT.Initialization,-      Graphics.UI.GLUT.Menu,-      Graphics.UI.GLUT.Objects,-      Graphics.UI.GLUT.Overlay,-      Graphics.UI.GLUT.State,-      Graphics.UI.GLUT.Window-   other-modules:-      Graphics.UI.GLUT.Callbacks.Registration,-      Graphics.UI.GLUT.QueryUtils,-      Graphics.UI.GLUT.Raw,-      Graphics.UI.GLUT.Raw.APIEntry,-      Graphics.UI.GLUT.Raw.Callbacks,-      Graphics.UI.GLUT.Raw.Fonts,-      Graphics.UI.GLUT.Raw.Functions,-      Graphics.UI.GLUT.Raw.Tokens,-      Graphics.UI.GLUT.Types-   include-dirs: include-   c-sources:-      cbits/HsGLUT.c-   build-depends: base >= 3 && < 5, array >= 0.3, containers >= 0.3, OpenGL >= 2.8.0.0, OpenGLRaw >= 1.3.0.0-   ghc-options: -Wall -O2-   if os(windows) && flag(UseNativeWindowsLibraries)-      if arch(i386)-         cpp-options: "-DCALLCONV=stdcall"-      else-         cpp-options: "-DCALLCONV=ccall"-      cc-options: "-DUSE_GETPROCADDRESS"-      extra-libraries: glut32-   else+  exposed-modules:+    Graphics.UI.GLUT+    Graphics.UI.GLUT.Begin+    Graphics.UI.GLUT.Callbacks+    Graphics.UI.GLUT.Callbacks.Global+    Graphics.UI.GLUT.Callbacks.Window+    Graphics.UI.GLUT.Colormap+    Graphics.UI.GLUT.Debugging+    Graphics.UI.GLUT.DeviceControl+    Graphics.UI.GLUT.Fonts+    Graphics.UI.GLUT.GameMode+    Graphics.UI.GLUT.Initialization+    Graphics.UI.GLUT.Menu+    Graphics.UI.GLUT.Objects+    Graphics.UI.GLUT.Overlay+    Graphics.UI.GLUT.State+    Graphics.UI.GLUT.Window+  other-modules:+    Graphics.UI.GLUT.Callbacks.Registration+    Graphics.UI.GLUT.QueryUtils+    Graphics.UI.GLUT.Raw+    Graphics.UI.GLUT.Raw.APIEntry+    Graphics.UI.GLUT.Raw.Callbacks+    Graphics.UI.GLUT.Raw.Fonts+    Graphics.UI.GLUT.Raw.Functions+    Graphics.UI.GLUT.Raw.Tokens+    Graphics.UI.GLUT.Types+  c-sources:+     cbits/HsGLUT.c+  hs-source-dirs: src+  include-dirs: include+  build-depends: base >= 3 && < 5, array >= 0.3, containers >= 0.3, OpenGL >= 2.8.0.0, OpenGLRaw >= 1.3.0.0+  default-language: Haskell2010+  other-extensions: CPP+  ghc-options: -Wall -O2+  if os(windows) && flag(UseNativeWindowsLibraries)+    if arch(i386)+      cpp-options: "-DCALLCONV=stdcall"+    else       cpp-options: "-DCALLCONV=ccall"-      cc-options: "-DUSE_DLSYM"-      if os(darwin)-         frameworks: GLUT-      else-         extra-libraries: glut+    cc-options: "-DUSE_GETPROCADDRESS"+    extra-libraries: glut32+  else+    cpp-options: "-DCALLCONV=ccall"+    cc-options: "-DUSE_DLSYM"+    if os(darwin)+      frameworks: GLUT+    else+      extra-libraries: glut  source-repository head-  type:     git-  location: https://github.com/haskell-opengl/GLUT+  type: git+  location: https://github.com/haskell-opengl/GLUT.git
− Graphics/UI/GLUT.hs 
@@ -1,386 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Graphics.UI.GLUT--- Copyright   :  (c) Sven Panne 2002-2013--- License     :  BSD3------ Maintainer  :  Sven Panne <svenpanne@gmail.com>--- Stability   :  stable--- Portability :  portable------ A Haskell binding for GLUT, the OpenGL Utility Toolkit, a window system--- independent toolkit for writing OpenGL programs. It includes support for--- the extended functionality available in freeglut (see--- <http://freeglut.sourceforge.net/>) and OpenGLUT (see--- <http://openglut.sourceforge.net/>), too.-----------------------------------------------------------------------------------module Graphics.UI.GLUT (-   -- * Legal stuff--   -- $LegalStuff--   -- * Introduction--   -- $Introduction--   -- ** Background--   -- $Background--   -- ** Design Philosophy--   -- $DesignPhilosophy--   -- ** API Versions--   -- $APIVersions--   -- ** Conventions--   -- $Conventions--   -- ** Terminology--   -- $Terminology--   module Graphics.Rendering.OpenGL,--   module Graphics.UI.GLUT.Initialization,-   module Graphics.UI.GLUT.Begin,-   module Graphics.UI.GLUT.Window,-   module Graphics.UI.GLUT.Overlay,-   module Graphics.UI.GLUT.Menu,-   module Graphics.UI.GLUT.Callbacks,-   module Graphics.UI.GLUT.Colormap,-   module Graphics.UI.GLUT.State,-   module Graphics.UI.GLUT.Fonts,-   module Graphics.UI.GLUT.Objects,-   module Graphics.UI.GLUT.Debugging,-   module Graphics.UI.GLUT.DeviceControl,-   module Graphics.UI.GLUT.GameMode-)  where--import Graphics.Rendering.OpenGL--import Graphics.UI.GLUT.Initialization-import Graphics.UI.GLUT.Begin-import Graphics.UI.GLUT.Window-import Graphics.UI.GLUT.Overlay-import Graphics.UI.GLUT.Menu-import Graphics.UI.GLUT.Callbacks-import Graphics.UI.GLUT.Colormap-import Graphics.UI.GLUT.State-import Graphics.UI.GLUT.Fonts-import Graphics.UI.GLUT.Objects-import Graphics.UI.GLUT.Debugging-import Graphics.UI.GLUT.DeviceControl-import Graphics.UI.GLUT.GameMode---------------------------------------------------------------------------------- $LegalStuff--- This documentation is heavily based on the man pages of Mark J. Kilgard\'s--- GLUT library.------ OpenGL is a trademark of Silicon Graphics, Inc.--- X Window System is a trademark of X Consortium, Inc.--- Spaceball is a registered trademark of Spatial Systems, Inc.------ The author has taken care in preparation of this documentation but makes--- no expressed or implied warranty of any kind and assumes no responsibility--- for errors or omissions. No liability is assumed for incidental or--- consequential damages in connection with or arising from the use of--- information or programs contained herein.---------------------------------------------------------------------------------- $Introduction--- The OpenGL Utility Toolkit (GLUT) is a programming interface for writing--- window system independent OpenGL programs. Currently there are--- implementations for the X Window System, the Windows family, OS\/2, and Mac.--- The toolkit supports the following functionality:------ * Multiple windows for OpenGL rendering.------ * Callback driven event processing.------ * Sophisticated input devices.------ * An /idle/ routine and timers.------ * A simple, cascading pop-up menu facility.------ * Utility routines to generate various solid and wire frame objects.------ * Support for bitmap and stroke fonts.------ * Miscellaneous window management functions, including managing overlays.------ This documentation serves as both a specification and a programming guide.--- If you are interested in a brief introduction to programming with GLUT,--- have a look at the relevant parts of <http://www.opengl.org/> and the vast--- amount of books on OpenGL, most of them use GLUT.------ The remainder of this section describes GLUT\'s design philosophy and--- usage model. The following sections specify the GLUT routines, grouped by--- functionality. The final sections discuss usage advice and the logical--- programmer visible state maintained by GLUT.---------------------------------------------------------------------------------- $Background--- One of the major accomplishments in the specification of OpenGL was--- the isolation of window system dependencies from OpenGL\'s rendering--- model. The result is that OpenGL is window system independent.------ Window system operations such as the creation of a rendering window and the--- handling of window system events are left to the native window system to--- define. Necessary interactions between OpenGL and the window system such as--- creating and binding an OpenGL context to a window are described separately--- from the OpenGL specification in a window system dependent specification. For--- example, the GLX specification describes the standard by which OpenGL--- interacts with the X Window System.------ The predecessor to OpenGL is IRIS GL. Unlike OpenGL, IRIS GL /does/--- specify how rendering windows are created and manipulated. IRIS GL\'s--- windowing interface is reasonably popular largely because it is simple to--- use. IRIS GL programmers can worry about graphics programming without needing--- to be an expert in programming the native window system. Experience also--- demonstrated that IRIS GL\'s windowing interface was high-level enough that--- it could be retargeted to different window systems. Silicon Graphics migrated--- from NeWS to the X Window System without any major changes to IRIS GL\'s--- basic windowing interface.------ Removing window system operations from OpenGL is a sound decision because it--- allows the OpenGL graphics system to be retargeted to various systems--- including powerful but expensive graphics workstations as well as--- mass-production graphics systems like video games, set-top boxes for--- interactive television, and PCs.------ Unfortunately, the lack of a window system interface for OpenGL is a gap in--- OpenGL\'s utility. Learning native window system APIs such as the X Window--- System\'s Xlib or Motif can be daunting. Even those familiar with--- native window system APIs need to understand the interface that binds OpenGL--- to the native window system. And when an OpenGL program is written using the--- native window system interface, despite the portability of the program\'s--- OpenGL rendering code, the program itself will be window system dependent.------ Testing and documenting OpenGL\'s functionality lead to the development of--- the @tk@ and @aux@ toolkits. The @aux@ toolkit is used in the examples found--- in the /OpenGL Programming Guide/. Unfortunately, @aux@ has numerous--- limitations and its utility is largely limited to toy programs. The @tk@--- library has more functionality than @aux@ but was developed in an /ad hoc/--- fashion and still lacks much important functionality that IRIS GL programmers--- expect, like pop-up menus and overlays.------ GLUT is designed to fill the need for a window system independent programming--- interface for OpenGL programs. The interface is designed to be simple yet--- still meet the needs of useful OpenGL programs. Features from the IRIS GL,--- @aux@, and @tk@ interfaces are included to make it easy for programmers used--- to these interfaces to develop programs for GLUT.---------------------------------------------------------------------------------- $DesignPhilosophy--- GLUT simplifies the implementation of programs using OpenGL rendering. The--- GLUT application programming interface (API) requires very few routines to--- display a graphics scene rendered using OpenGL. The GLUT API (like the OpenGL--- API) is stateful. Most initial GLUT state is defined and the initial state is--- reasonable for simple programs. The GLUT routines also take relatively few--- parameters.------ The GLUT API is (as much as reasonable) window system independent. For this--- reason, GLUT does not return /any/ native window system handles, pointers, or--- other data structures. More subtle window system dependencies such as--- reliance on window system dependent fonts are avoided by GLUT; instead, GLUT--- supplies its own (limited) set of fonts.------ For programming ease, GLUT provides a simple menu sub-API. While the menuing--- support is designed to be implemented as pop-up menus, GLUT gives window--- system leeway to support the menu functionality in another manner (pull-down--- menus for example).------ Two of the most important pieces of GLUT state are the /current window/ and--- /current menu/. Most window and menu routines affect the /current window/ or--- /menu/ respectively. Most callbacks implicitly set the /current window/ and--- /menu/ to the appropriate window or menu responsible for the callback. GLUT--- is designed so that a program with only a single window and\/or menu will not--- need to keep track of any window or menu identifiers. This greatly simplifies--- very simple GLUT programs.------ GLUT is designed for simple to moderately complex programs focused on OpenGL--- rendering. GLUT implements its own event loop. For this reason, mixing GLUT--- with other APIs that demand their own event handling structure may be--- difficult. The advantage of a builtin event dispatch loop is simplicity.------ GLUT contains routines for rendering fonts and geometric objects, however--- GLUT makes no claims on the OpenGL display list name space. For this reason,--- none of the GLUT rendering routines use OpenGL display lists. It is up to the--- GLUT programmer to compile the output from GLUT rendering routines into--- display lists if this is desired.------ GLUT routines are logically organized into several sub-APIs according to--- their functionality. The sub-APIs are:------ * /Initialization:/ Command line processing, window system initialization,---   and initial window creation state are controlled by these routines.------ * /Beginning Event Processing:/ This routine enters GLUT\'s event processing---   loop. This routine never returns, and it continuously calls GLUT callbacks---   as necessary.------ * /Window Management:/ These routines create and control windows.------ * /Overlay Management:/ These routines establish and manage overlays for---   windows.------ * /Menu Management:/ These routines create and control pop-up menus.------ * /Callback Registration:/ These routines register callbacks to be called by---   the GLUT event processing loop.------ * /Color Index Colormap Management:/ These routines allow the manipulation---   of color index colormaps for windows.------ * /State Retrieval:/ These routines allows programs to retrieve state from---   GLUT.------ * /Font Rendering:/ These routines allow rendering of stroke and bitmap---   fonts.------ * /Geometric Shape Rendering:/ These routines allow the rendering of 3D---   geometric objects including spheres, cones, icosahedrons, and teapots.------ * /Debugging:/ This routine reports any pending GL errors.------ * /Device Control:/ These routines allow setting the key repeat and polling---   the joystick.------ * /Game Mode:/ These routines allow programs to enter\/leave a full-screen---   mode with specified properties.---- Note that the following item has been left out intentionally, its--- implementation is too SGI-specific:--- * /Video Resizing:/ These routines provide a means for doing swap or frame---   synchronous resizing\/panning of the area that is to be magnified (or---   passed through) to the output video resolution.---------------------------------------------------------------------------------- $APIVersions--- The GLUT API has undergone several revisions with increasing functionality.--- This Haskell binding provides access to everything in API version 4,--- although it is not yet officially finalized. Nevertheless, it provides very--- useful things like handling full-screen modes and special keys.---------------------------------------------------------------------------------- $Conventions--- GLUT window and screen coordinates are expressed in pixels. The upper--- left hand corner of the screen or a window is (0,0). X coordinates--- increase in a rightward direction; Y coordinates increase in a--- downward direction. Note: This is inconsistent with OpenGL\'s--- coordinate scheme that generally considers the lower left hand--- coordinate of a window to be at (0,0) but is consistent with most--- popular window systems.---------------------------------------------------------------------------------- $Terminology--- A number of terms are used in a GLUT-specific manner throughout this--- document. The GLUT meaning of these terms is independent of the window--- system GLUT is used with. Here are GLUT-specific meanings for the--- following GLUT-specific terms:------ * /Callback:/ A programmer specified routine that can be registered with---   GLUT to be called in response to a specific type of event. Also used to--- refer to a specific callback routine being called.------ * /Colormap:/ A mapping of pixel values to RGB color values. Used by color---   index windows.------ * /Dials and button box:/ A sophisticated input device consisting of a pad---   of buttons and an array of rotating dials, often used by computer-aided---   design programs.------ * /Display mode:/ A set of OpenGL frame buffer capabilities that can be---   attributed to a window.------ * /Idle:/ A state when no window system events are received for processing---   as callbacks and the idle callback, if one is registered, is called.------ * /Layer in use:/ Either the normal plane or overlay. This per-window state---   determines what frame buffer layer OpenGL commands affect.------ * /Menu entry:/ A menu item that the user can select to trigger the menu---   callback for the menu entry\'s value.------ * /Menu item:/ Either a menu entry or a sub-menu trigger.------ * /Modifiers:/ The Shift, Ctrl, and Alt keys that can be held down---   simultaneously with a key or mouse button being pressed or released.------ * /Multisampling:/ A technique for hardware antialiasing generally available---   only on expensive 3D graphics hardware. Each pixel is composed of a number---   of samples (each containing color and depth information). The samples are---   averaged to determine the displayed pixel color value. Multisampling is---   supported as an extension to OpenGL.------ * /Normal plane:/ The default frame buffer layer where GLUT window state---   resides; as opposed to the /overlay/.------ * /Overlay:/ A frame buffer layer that can be displayed preferentially to---   the /normal plane/ and supports transparency to display through to the---   /normal plane/. Overlays are useful for rubber-banding effects, text---   annotation, and other operations, to avoid damaging the normal plane frame---   buffer state. Overlays require hardware support not present on all systems.------ * /Pop:/ The act of forcing a window to the top of the stacking order for---   sibling windows.------ * /Pop-up menu:/ A menu that can be set to appear when a specified mouse---   button is pressed in a window. A pop-menu consists of multiple menu items.------ * /Push:/ The act of forcing a window to the bottom of the stacking order---   for sibling windows.------ * /Reshape:/ The act of changing the size or shape of the window.------ * /Spaceball:/ A sophisticated 3D input device that provides six degrees of---   freedom, three axes of rotation and three axes of translation. It also---   supports a number of buttons. The device is a hand-sized ball attached to---   a base. By cupping the ball with one\'s hand and applying torsional or---   directional force on the ball, rotations and translationsare generated.------ * /Stereo:/ A frame buffer capability providing left and right color buffers---   for creating stereoscopic renderings. Typically, the user wears LCD---   shuttered goggles synchronized with the alternating display on the screen---   of the left and right color buffers.------ * /Sub-menu:/ A menu cascaded from some sub-menu trigger.------ * /Sub-menu trigger:/ A menu item that the user can enter to cascade another---   pop-up menu.------ * /Subwindow:/ A type of window that is the child window of a top-level---   window or other subwindow. The drawing and visible region of a subwindow---   is limited by its parent window.------ * /Tablet:/ A precise 2D input device. Like a mouse, 2D coordinates are---   returned. The absolute position of the tablet \"puck\" on the tablet is---   returned. Tablets also support a number of buttons.------ * /Timer:/ A callback that can be scheduled to be called in a specified---   interval of time.------ * /Top-level window:/ A window that can be placed, moved, resized, etc.---   independently from other top-level windows by the user. Subwindows may---   reside within a top-level window.------ * /Window:/ A rectangular area for OpenGL rendering.------ * /Window display state:/ One of shown, hidden, or iconified. A shown window---   is potentially visible on the screen (it may be obscured by other windows---   and not actually visible). A hidden window will never be visible. An---   iconified window is not visible but could be made visible in response to---   some user action like clicking on the window\'s corresponding icon.------ * /Window system:/ A broad notion that refers to both the mechanism and---   policy of the window system. For example, in the X Window System both the---   window manager and the X server are integral to what GLUT considers the---   window system.
− Graphics/UI/GLUT/Begin.hs 
@@ -1,102 +0,0 @@------------------------------------------------------------------------------------ |--- Module      :  Graphics.UI.GLUT.Begin--- Copyright   :  (c) Sven Panne 2002-2013--- License     :  BSD3------ Maintainer  :  Sven Panne <svenpanne@gmail.com>--- Stability   :  stable--- Portability :  portable------ After a GLUT program has done initial setup such as creating windows and--- menus, GLUT programs enter the GLUT event processing loop by calling--- 'mainLoop' or handle events iteratively with 'mainLoopEvent'.--------------------------------------------------------------------------------------module Graphics.UI.GLUT.Begin (-   -- * Handling events-   mainLoop, mainLoopEvent, leaveMainLoop,--   -- * Controlling the behaviour when windows are closed-   ActionOnWindowClose(..), actionOnWindowClose-) where--import Foreign.C.Types-import Graphics.Rendering.OpenGL.GL.StateVar-import Graphics.UI.GLUT.QueryUtils-import Graphics.UI.GLUT.Raw-------------------------------------------------------------------------------------- | Enter the GLUT event processing loop; it will call as necessary any--- callbacks that have been registered. This routine should be called at most--- once in a GLUT program.--mainLoop :: IO ()-mainLoop = glutMainLoop-------------------------------------------------------------------------------------- | (/freeglut only/) Process one iteration's worth of events in its event loop.--- This allows the application to control its own event loop and still use the--- GLUT package.--mainLoopEvent :: IO ()-mainLoopEvent = glutMainLoopEvent-------------------------------------------------------------------------------------- | (/freeglut only/) Stop the event loop. If 'actionOnWindowClose' contains--- 'Exit', the application will exit; otherwise control will return to the--- function which called 'mainLoop'.------ If the application has two nested calls to 'mainLoop' and calls--- 'leaveMainLoop', the behaviour is undefined. It may leave only the inner--- nested loop or it may leave both loops. If the reader has a strong preference--- for one behaviour over the other he should contact the freeglut Programming--- Consortium and ask for the code to be fixed.--leaveMainLoop :: IO ()-leaveMainLoop = glutLeaveMainLoop-------------------------------------------------------------------------------------- | The behaviour when the user closes a window.--data ActionOnWindowClose-   = -- | Exit the whole program when any window is closed or 'leaveMainLoop'-     -- is called (default).-     Exit-   | -- | Return from mainLoop when any window is closed.-     MainLoopReturns-   | -- | Return from mainLoop after the last window is closed.-     ContinueExecution-   | ContinueExectuion-   deriving ( Eq, Ord, Show )--{-# DEPRECATED ContinueExectuion "Use 'ContinueExecution' instead." #-}--marshalActionOnWindowClose :: ActionOnWindowClose -> CInt-marshalActionOnWindowClose x = case x of-   Exit ->  glut_ACTION_EXIT-   MainLoopReturns -> glut_ACTION_GLUTMAINLOOP_RETURNS-   ContinueExecution -> glut_ACTION_CONTINUE_EXECUTION-   ContinueExectuion -> glut_ACTION_CONTINUE_EXECUTION--unmarshalActionOnWindowClose :: CInt -> ActionOnWindowClose-unmarshalActionOnWindowClose x-   | x == glut_ACTION_EXIT = Exit-   | x == glut_ACTION_GLUTMAINLOOP_RETURNS = MainLoopReturns-   | x == glut_ACTION_CONTINUE_EXECUTION = ContinueExecution-   | otherwise = error ("unmarshalActionOnWindowClose: illegal value " ++ show x)----------------------------------------------------------------------------------- | (/freeglut only/) Controls the behaviour when the user closes a window.--actionOnWindowClose :: StateVar ActionOnWindowClose-actionOnWindowClose =-   makeStateVar-      (simpleGet unmarshalActionOnWindowClose glut_ACTION_ON_WINDOW_CLOSE)-      (glutSetOption glut_ACTION_ON_WINDOW_CLOSE . marshalActionOnWindowClose)
− Graphics/UI/GLUT/Callbacks.hs 
@@ -1,47 +0,0 @@------------------------------------------------------------------------------------ |--- Module      :  Graphics.UI.GLUT.Callbacks--- Copyright   :  (c) Sven Panne 2002-2013--- License     :  BSD3------ Maintainer  :  Sven Panne <svenpanne@gmail.com>--- Stability   :  stable--- Portability :  portable--------- GLUT supports a number of callbacks to respond to events. There are three--- types of callbacks: window, menu, and global. Window callbacks indicate when--- to redisplay or reshape a window, when the visibility of the window changes,--- and when input is available for the window. Menu callbacks are described in--- "Graphics.UI.GLUT.Menu". The global callbacks manage the passing of time and--- menu usage. The calling order of callbacks between different windows is--- undefined.------ Callbacks for input events should be delivered to the window the event occurs--- in. Events should not propagate to parent windows.------ A callback of type @Foo@ can registered by setting @fooCallback@ to 'Just'--- the callback. Almost all callbacks can be de-registered by setting--- the corresponding @fooCallback@ to 'Nothing', the only exceptions being--- 'Graphics.UI.GLUT.Callbacks.Window.DisplayCallback' (can only be--- re-registered) and 'Graphics.UI.GLUT.Callbacks.Global.TimerCallback' (can\'t--- be unregistered).------ /X Implementation Notes:/ The X GLUT implementation uses the X Input--- extension to support sophisticated input devices: Spaceball, dial & button--- box, and digitizing tablet. Because the X Input extension  does not mandate--- how particular types of devices are advertised through the extension, it is--- possible GLUT for X may not correctly support input devices that would--- otherwise be of the correct type. The X GLUT implementation will support the--- Silicon Graphics Spaceball, dial & button box, and digitizing tablet as--- advertised through the X Input extension.--------------------------------------------------------------------------------------module Graphics.UI.GLUT.Callbacks (-   module Graphics.UI.GLUT.Callbacks.Window,-   module Graphics.UI.GLUT.Callbacks.Global-) where--import Graphics.UI.GLUT.Callbacks.Window-import Graphics.UI.GLUT.Callbacks.Global
− Graphics/UI/GLUT/Callbacks/Global.hs 
@@ -1,114 +0,0 @@------------------------------------------------------------------------------------ |--- Module      :  Graphics.UI.GLUT.Callbacks.Global--- Copyright   :  (c) Sven Panne 2002-2013--- License     :  BSD3------ Maintainer  :  Sven Panne <svenpanne@gmail.com>--- Stability   :  stable--- Portability :  portable--------------------------------------------------------------------------------------module Graphics.UI.GLUT.Callbacks.Global (-   -- * Menu status callback-   MenuUsage(..), MenuStatusCallback, menuStatusCallback,--   -- * Idle callback-   IdleCallback, idleCallback,--   -- * Timer callbacks-   Timeout, TimerCallback, addTimerCallback-) where--import Control.Monad.Fix-import Foreign.C.Types-import Graphics.Rendering.OpenGL ( Position(..)-                                 , SettableStateVar-                                 , makeSettableStateVar )-import Graphics.UI.GLUT.Callbacks.Registration-import Graphics.UI.GLUT.Raw------------------------------------------------------------------------------------data MenuUsage-   = NotInUse-   | InUse-   deriving ( Eq, Ord, Show )--unmarshalMenuUsage :: CInt -> MenuUsage-unmarshalMenuUsage x-   | x == glut_MENU_NOT_IN_USE = NotInUse-   | x == glut_MENU_IN_USE = InUse-   | otherwise = error ("unmarshalMenuUsage: illegal value " ++ show x)--type MenuStatusCallback  = MenuUsage -> Position -> IO ()---- | Controls the global menu status callback so a GLUT program can determine--- when a menu is in use or not. When a menu status callback is registered, it--- will be called with the value 'InUse' when pop-up menus are in use by the--- user; and the callback will be called with the value 'NotInUse' when pop-up--- menus are no longer in use. Additionally, the location in window coordinates--- of the button press that caused the menu to go into use, or the location where--- the menu was released (maybe outside the window). Other callbacks continue to--- operate (except mouse motion callbacks) when pop-up menus are in use so the--- menu status callback allows a program to suspend animation or other tasks--- when menus are in use. The cascading and unmapping of sub-menus from an--- initial pop-up menu does not generate menu status callbacks. There is a--- single menu status callback for GLUT.------ When the menu status callback is called, the /current menu/ will be set to--- the initial pop-up menu in both the 'InUse' and 'NotInUse' cases. The--- /current window/ will be set to the window from which the initial menu was--- popped up from, also in both cases.--menuStatusCallback :: SettableStateVar (Maybe MenuStatusCallback)-menuStatusCallback =-   makeSettableStateVar $-      setCallback MenuStatusCB glutMenuStatusFunc-                  (makeMenuStatusFunc . unmarshal)-   where unmarshal cb s x y =-            cb (unmarshalMenuUsage s)-               (Position (fromIntegral x) (fromIntegral y))------------------------------------------------------------------------------------type IdleCallback = IO ()---- | Controls the global idle callback so a GLUT program can perform background--- processing tasks or continuous animation when window system events are not--- being received. If enabled, the idle callback is continuously called when--- events are not being received. The /current window/ and /current menu/ will--- not be changed before the idle callback. Programs with multiple windows--- and\/or menus should explicitly set the /current window/ and\/or /current--- menu/ and not rely on its current setting.------ The amount of computation and rendering done in an idle callback should be--- minimized to avoid affecting the program\'s interactive response. In general,--- not more than a single frame of rendering should be done in an idle callback.--idleCallback :: SettableStateVar (Maybe IdleCallback)-idleCallback =-   makeSettableStateVar $ setCallback IdleCB glutIdleFunc makeIdleFunc-------------------------------------------------------------------------------------- | Timeout for the timer callback in milliseconds-type Timeout = Int--type TimerCallback  = IO ()---- | Register a one-shot timer callback to be triggered after at least the given--- amount of time. Multiple timer callbacks at same or differing times may be--- registered simultaneously. There is no support for canceling a registered--- callback.------ The number of milliseconds is a lower bound on the time before the callback--- is generated. GLUT attempts to deliver the timer callback as soon as possible--- after the expiration of the callback\'s time interval.--addTimerCallback :: Timeout -> TimerCallback -> IO ()-addTimerCallback msecs timerCallback = do-   funPtr <- mfix (\self -> makeTimerFunc (\_ -> do registerForCleanup self-                                                    timerCallback))-   glutTimerFunc (fromIntegral msecs) funPtr 0
− Graphics/UI/GLUT/Callbacks/Registration.hs 
@@ -1,162 +0,0 @@-{-# OPTIONS_GHC -fno-cse #-}--{-# OPTIONS_HADDOCK hide #-}------------------------------------------------------------------------------------ |--- Module      :  Graphics.UI.GLUT.Callbacks.Registration--- Copyright   :  (c) Sven Panne 2002-2013--- License     :  BSD3------ Maintainer  :  Sven Panne <svenpanne@gmail.com>--- Stability   :  stable--- Portability :  portable--------------------------------------------------------------------------------------module Graphics.UI.GLUT.Callbacks.Registration (-   CallbackType(..), registerForCleanup, setCallback, getCurrentWindow-) where------------------------------------------------------------------------------------import Control.Monad-import Data.IORef-import qualified Data.Map as Map ( empty, lookup, insert, delete )-import Data.Map ( Map )-import Foreign.Ptr-import Graphics.Rendering.OpenGL ( get )-import Graphics.UI.GLUT.Raw-import Graphics.UI.GLUT.Window------------------------------------------------------------------------------------- No timer callback here, because they are one-shot and "self destroy"--data CallbackType-   = DisplayCB         | OverlayDisplayCB  | ReshapeCB-   | KeyboardCB        | KeyboardUpCB      | MouseCB-   | MotionCB          | PassiveMotionCB   | CrossingCB-   | VisibilityCB      | WindowStatusCB    | SpecialCB-   | SpecialUpCB       | SpaceballMotionCB | SpaceballRotateCB-   | SpaceballButtonCB | ButtonBoxCB       | DialsCB-   | TabletMotionCB    | TabletButtonCB    | JoystickCB-   | MenuStatusCB      | IdleCB-   -- freeglut-only callback types-   | CloseCB           | MouseWheelCB      | PositionCB-   | MultiEntryCB      | MultiMotionCB     | MultiButtonCB-   | MultiPassiveCB    | InitContextCB     | AppStatusCB-   deriving ( Eq, Ord )--isGlobal :: CallbackType -> Bool-isGlobal MenuStatusCB = True-isGlobal IdleCB       = True-isGlobal _            = False------------------------------------------------------------------------------------- To uniquely identify a particular callback, the associated window is needed--- for window callbacks.--data CallbackID = CallbackID (Maybe Window) CallbackType-   deriving ( Eq, Ord )--getCallbackID :: CallbackType -> IO CallbackID-getCallbackID callbackType = do-   maybeWindow <- if isGlobal callbackType-                     then return Nothing-                     else fmap Just $ getCurrentWindow "getCallbackID"-   return $ CallbackID maybeWindow callbackType--getCurrentWindow :: String -> IO Window-getCurrentWindow func = do-   win <- get currentWindow-   maybe (error (func ++ ": no current window")) return win------------------------------------------------------------------------------------- This seems to be a common Haskell hack nowadays: A plain old global variable--- with an associated mutator. Perhaps some language/library support is needed?--{-# NOINLINE theCallbackTable #-}-theCallbackTable :: IORef (CallbackTable a)-theCallbackTable = unsafePerformIO (newIORef emptyCallbackTable)--getCallbackTable :: IO (CallbackTable a)-getCallbackTable = readIORef theCallbackTable--modifyCallbackTable :: (CallbackTable a -> CallbackTable a) -> IO ()-modifyCallbackTable = modifyIORef theCallbackTable------------------------------------------------------------------------------------type CallbackTable a = Map CallbackID (FunPtr a)--emptyCallbackTable :: CallbackTable a-emptyCallbackTable = Map.empty--lookupInCallbackTable :: CallbackID -> IO (Maybe (FunPtr a))-lookupInCallbackTable callbackID =-   fmap (Map.lookup callbackID) getCallbackTable--deleteFromCallbackTable :: CallbackID -> IO ()-deleteFromCallbackTable callbackID =-   modifyCallbackTable (Map.delete callbackID)--addToCallbackTable :: CallbackID -> FunPtr a -> IO ()-addToCallbackTable callbackID funPtr =-   modifyCallbackTable (Map.insert callbackID funPtr)------------------------------------------------------------------------------------- Another global mutable variable: The list of function pointers ready to be--- freed by freeHaskellFunPtr--{-# NOINLINE theCleanupList #-}-theCleanupList :: IORef [FunPtr a]-theCleanupList = unsafePerformIO (newIORef [])--getCleanupList :: IO [FunPtr a]-getCleanupList = readIORef theCleanupList--setCleanupList :: [FunPtr a] -> IO ()-setCleanupList = writeIORef theCleanupList------------------------------------------------------------------------------------- And yet another mutable (write-once) variable: A function pointer to a--- callback which frees all function pointers on the cleanup list.--{-# NOINLINE theScavenger #-}-theScavenger :: IORef (FunPtr TimerFunc)-theScavenger = unsafePerformIO (newIORef =<< makeTimerFunc (\_ -> do-   cleanupList <- getCleanupList-   mapM_ freeHaskellFunPtr cleanupList-   setCleanupList []))--getScavenger :: IO (FunPtr TimerFunc)-getScavenger = readIORef theScavenger------------------------------------------------------------------------------------- Here is the really cunning stuff: If an element is added to the cleanup list--- when it is empty, register an immediate callback at GLUT to free the list as--- soon as possible.--registerForCleanup :: FunPtr a -> IO ()-registerForCleanup funPtr = do-   oldCleanupList <- getCleanupList-   setCleanupList (funPtr : oldCleanupList)-   when (null oldCleanupList) $ do-        scavenger <- getScavenger-        glutTimerFunc 0 scavenger 0------------------------------------------------------------------------------------setCallback :: CallbackType -> (FunPtr a -> IO ()) -> (b -> IO (FunPtr a))-            -> Maybe b -> IO ()-setCallback callbackType registerAtGLUT makeCallback maybeCallback = do-   callbackID <- getCallbackID callbackType-   maybeOldFunPtr <- lookupInCallbackTable callbackID-   case maybeOldFunPtr of-      Nothing -> return ()-      Just oldFunPtr -> do registerForCleanup oldFunPtr-                           deleteFromCallbackTable callbackID-   case maybeCallback of-      Nothing -> registerAtGLUT nullFunPtr-      Just callback -> do newFunPtr <- makeCallback callback-                          addToCallbackTable callbackID newFunPtr-                          registerAtGLUT newFunPtr
− Graphics/UI/GLUT/Callbacks/Window.hs 
@@ -1,991 +0,0 @@------------------------------------------------------------------------------------ |--- Module      :  Graphics.UI.GLUT.Callbacks.Window--- Copyright   :  (c) Sven Panne 2002-2013--- License     :  BSD3------ Maintainer  :  Sven Panne <svenpanne@gmail.com>--- Stability   :  stable--- Portability :  portable--------------------------------------------------------------------------------------module Graphics.UI.GLUT.Callbacks.Window (-   -- * Redisplay callbacks-   DisplayCallback, displayCallback, overlayDisplayCallback,--   -- * Reshape callback-   ReshapeCallback, reshapeCallback,--   -- * Position callback-   PositionCallback, positionCallback,--   -- * Callbacks for visibility changes-   Visibility(..), VisibilityCallback, visibilityCallback,-   WindowState(..), WindowStateCallback, windowStateCallback,--   -- * Window close callback-   CloseCallback, closeCallback,--   -- * Life cycle callbacks for mobile platforms-   InitContextCallback, initContextCallback,-   AppStatus(..), AppStatusCallback, appStatusCallback,--   -- * Keyboard callback-   KeyboardCallback, keyboardCallback, keyboardUpCallback,--   -- * Special callback-   SpecialCallback, specialCallback, specialUpCallback,--   -- * Mouse callback-   MouseCallback, mouseCallback,--   -- * Keyboard and mouse input callback-   Key(..), SpecialKey(..), MouseButton(..), KeyState(..), Modifiers(..),-   KeyboardMouseCallback, keyboardMouseCallback,--   -- * Mouse wheel callback-   WheelNumber, WheelDirection, MouseWheelCallback, mouseWheelCallback,--   -- * Mouse movement callbacks-   MotionCallback, motionCallback, passiveMotionCallback,-   Crossing(..), CrossingCallback, crossingCallback,--   -- * Spaceball callback-   SpaceballMotion, SpaceballRotation, ButtonIndex, SpaceballInput(..),-   SpaceballCallback, spaceballCallback,--   -- * Dial & button box callback-   DialAndButtonBoxInput(..), DialIndex,-   DialAndButtonBoxCallback, dialAndButtonBoxCallback,--   -- * Tablet callback-   TabletPosition(..), TabletInput(..), TabletCallback, tabletCallback,--   -- * Joystick callback-   JoystickButtons(..), JoystickPosition(..),-   JoystickCallback, joystickCallback,--   -- * Multi-touch support-   TouchID,-   MultiMouseCallback, multiMouseCallback,-   MultiCrossingCallback, multiCrossingCallback,-   MultiMotionCallback, multiMotionCallback, multiPassiveMotionCallback--) where--import Data.Bits hiding ( shift )-import Data.Char-import Data.Maybe-import Foreign.C.Types-import Graphics.Rendering.OpenGL-import Graphics.UI.GLUT.Callbacks.Registration-import Graphics.UI.GLUT.Raw-import Graphics.UI.GLUT.State-import Graphics.UI.GLUT.Types-------------------------------------------------------------------------------------- | A display callback--type DisplayCallback = IO ()---- | Controls the display callback for the /current window./ When GLUT determines--- that the normal plane for the window needs to be redisplayed, the display--- callback for the window is called. Before the callback, the /current window/--- is set to the window needing to be redisplayed and (if no overlay display--- callback is registered) the /layer in use/ is set to the normal plane. The--- entire normal plane region should be redisplayed in response to the callback--- (this includes ancillary buffers if your program depends on their state).------ GLUT determines when the display callback should be triggered based on the--- window\'s redisplay state. The redisplay state for a window can be either set--- explicitly by calling 'Graphics.UI.GLUT.Window.postRedisplay' or implicitly--- as the result of window damage reported by the window system. Multiple posted--- redisplays for a window are coalesced by GLUT to minimize the number of--- display callbacks called.------ When an overlay is established for a window, but there is no overlay display--- callback registered, the display callback is used for redisplaying both the--- overlay and normal plane (that is, it will be called if either the redisplay--- state or overlay redisplay state is set). In this case, the /layer in use/ is--- not implicitly changed on entry to the display callback.------ See 'overlayDisplayCallback' to understand how distinct callbacks for the--- overlay and normal plane of a window may be established.------ When a window is created, no display callback exists for the window. It is--- the responsibility of the programmer to install a display callback for the--- window before the window is shown. A display callback must be registered for--- any window that is shown. If a window becomes displayed without a display--- callback being registered, a fatal error occurs. There is no way to--- \"deregister\" a display callback (though another callback routine can always--- be registered).------ Upon return from the display callback, the normal damaged state of the window--- (see 'Graphics.UI.GLUT.State.damaged') is cleared. If there is no overlay--- display callback registered the overlay damaged state of the window (see--- 'Graphics.UI.GLUT.State.damaged') is also cleared.--displayCallback :: SettableStateVar DisplayCallback-displayCallback = makeSettableStateVar $-   setCallback DisplayCB glutDisplayFunc makeDisplayFunc . Just-------------------------------------------------------------------------------------- | Controls the overlay display callback for the /current window./ The overlay--- display callback is functionally the same as the window\'s display callback--- except that the overlay display callback is used to redisplay the window\'s--- overlay.------ When GLUT determines that the overlay plane for the window needs to be--- redisplayed, the overlay display callback for the window is called. Before--- the callback, the /current window/ is set to the window needing to be--- redisplayed and the /layer in use/ is set to the overlay. The entire overlay--- region should be redisplayed in response to the callback (this includes--- ancillary buffers if your program depends on their state).------ GLUT determines when the overlay display callback should be triggered based--- on the window\'s overlay redisplay state. The overlay redisplay state for a--- window can be either set explicitly by calling--- 'Graphics.UI.GLUT.Overlay.postOverlayRedisplay' or implicitly as the result--- of window damage reported by the window system. Multiple posted overlay--- redisplays for a window are coalesced by GLUT to minimize the number of--- overlay display callbacks called.------ Upon return from the overlay display callback, the overlay damaged state of--- the window (see 'Graphics.UI.GLUT.State.damaged') is cleared.------ Initially there is no overlay display callback registered when an overlay is--- established. See 'displayCallback' to understand how the display callback--- alone is used if an overlay display callback is not registered.--overlayDisplayCallback :: SettableStateVar (Maybe DisplayCallback)-overlayDisplayCallback = makeSettableStateVar $-   setCallback OverlayDisplayCB glutOverlayDisplayFunc makeOverlayDisplayFunc-------------------------------------------------------------------------------------- | A reshape callback--type ReshapeCallback = Size -> IO ()---- | Controls the reshape callback for the /current window./ The reshape callback--- is triggered when a window is reshaped. A reshape callback is also triggered--- immediately before a window\'s first display callback after a window is--- created or whenever an overlay for the window is established. The parameter--- of the callback specifies the new window size in pixels. Before the callback,--- the /current window/ is set to the window that has been reshaped.------ If a reshape callback is not registered for a window or 'reshapeCallback' is--- set to 'Nothing' (to deregister a previously registered callback), the--- default reshape callback is used. This default callback will simply call------ @--- 'Graphics.Rendering.OpenGL.GL.CoordTrans.viewport' ('Graphics.Rendering.OpenGL.GL.CoordTrans.Position' 0 0) ('Graphics.Rendering.OpenGL.GL.CoordTrans.Size' /width/ /height/)--- @------ on the normal plane (and on the overlay if one exists).------ If an overlay is established for the window, a single reshape callback is--- generated. It is the callback\'s responsibility to update both the normal--- plane and overlay for the window (changing the layer in use as necessary).------ When a top-level window is reshaped, subwindows are not reshaped. It is up to--- the GLUT program to manage the size and positions of subwindows within a--- top-level window. Still, reshape callbacks will be triggered for subwindows--- when their size is changed using 'Graphics.UI.GLUT.Window.windowSize'.--reshapeCallback :: SettableStateVar (Maybe ReshapeCallback)-reshapeCallback = makeSettableStateVar $-   setCallback ReshapeCB glutReshapeFunc (makeReshapeFunc . unmarshal)-   where unmarshal cb w h = cb (Size (fromIntegral w) (fromIntegral h))-------------------------------------------------------------------------------------- | A position callback--type PositionCallback = Position -> IO ()---- | (/freeglut only/) Controls the position callback for the /current window./--- The position callback for a window is called when the position of a window--- changes.--positionCallback :: SettableStateVar (Maybe PositionCallback)-positionCallback = makeSettableStateVar $-   setCallback PositionCB glutPositionFunc (makePositionFunc . unmarshal)-   where unmarshal cb x y = cb (Position (fromIntegral x) (fromIntegral y))-------------------------------------------------------------------------------------- | The visibility state of the /current window/--data Visibility-   = NotVisible -- ^ No part of the /current window/ is visible, i.e., until the-                --   window\'s visibility changes, all further rendering to the-                --   window is discarded.-   | Visible    -- ^ The /current window/ is totally or partially visible. GLUT-                --   considers a window visible if any pixel of the window is-                --   visible or any pixel of any descendant window is visible on-                --   the screen.-   deriving ( Eq, Ord, Show )--unmarshalVisibility :: CInt -> Visibility-unmarshalVisibility x-   | x == glut_NOT_VISIBLE = NotVisible-   | x == glut_VISIBLE = Visible-   | otherwise = error ("unmarshalVisibility: illegal value " ++ show x)-------------------------------------------------------------------------------------- | A visibility callback--type VisibilityCallback = Visibility -> IO ()---- | Controls the visibility callback for the /current window./ The visibility--- callback for a window is called when the visibility of a window changes.------ If the visibility callback for a window is disabled and later re-enabled, the--- visibility status of the window is undefined; any change in window visibility--- will be reported, that is if you disable a visibility callback and re-enable--- the callback, you are guaranteed the next visibility change will be reported.------ Note that you can either use 'visibilityCallback' or 'windowStateCallback',--- but not both, because the former is implemented via the latter.--visibilityCallback :: SettableStateVar (Maybe VisibilityCallback)-visibilityCallback = makeSettableStateVar $-   setCallback VisibilityCB glutVisibilityFunc-               (makeVisibilityFunc . unmarshal)-   where unmarshal cb  = cb . unmarshalVisibility-------------------------------------------------------------------------------------- | The window state of the /current window/--data WindowState-   = Unmapped          -- ^ The /current window/ is unmapped.-   | FullyRetained     -- ^ The /current window/ is unobscured.-   | PartiallyRetained -- ^ The /current window/ is partially obscured.-   | FullyCovered      -- ^ The /current window/ is fully obscured.-   deriving ( Eq, Ord, Show )--unmarshalWindowState :: CInt -> WindowState-unmarshalWindowState x-   | x == glut_HIDDEN = Unmapped-   | x == glut_FULLY_RETAINED = FullyRetained-   | x == glut_PARTIALLY_RETAINED = PartiallyRetained-   | x == glut_FULLY_COVERED = FullyCovered-   | otherwise = error ("unmarshalWindowState: illegal value " ++ show x)-------------------------------------------------------------------------------------- | A window state callback--type WindowStateCallback = WindowState -> IO ()---- | Controls the window state callback for the--- /current window./ The window state callback for a window is called when the--- window state of a window changes.------ If the window state callback for a window is disabled and later re-enabled,--- the window state state of the window is undefined; any change in the window--- state will be reported, that is if you disable a window state callback and--- re-enable the callback, you are guaranteed the next window state change will--- be reported.------ Note that you can either use 'visibilityCallback' or 'windowStateCallback',--- but not both, because the former is implemented via the latter.--windowStateCallback :: SettableStateVar (Maybe WindowStateCallback)-windowStateCallback = makeSettableStateVar $-   setCallback WindowStatusCB glutWindowStatusFunc-               (makeWindowStatusFunc . unmarshal)-   where unmarshal cb  = cb . unmarshalWindowState-------------------------------------------------------------------------------------- | A window close callback--type CloseCallback = IO ()---- | Controls the window close callback for the /current window/.--closeCallback :: SettableStateVar (Maybe CloseCallback)-closeCallback = makeSettableStateVar $-   setCallback CloseCB glutCloseFunc makeCloseFunc-------------------------------------------------------------------------------------- | An initialize context callback--type InitContextCallback = IO ()---- | (/freeglut only/) Controls the initialize context callback for the /current--- window/.--initContextCallback :: SettableStateVar (Maybe InitContextCallback)-initContextCallback = makeSettableStateVar $-   setCallback InitContextCB glutInitContextFunc makeInitContextFunc-------------------------------------------------------------------------------------- | The application status of the /current window/--data AppStatus-   = AppStatusPause-   | AppStatusResume-   deriving ( Eq, Ord, Show )--unmarshalAppStatus :: CInt -> AppStatus-unmarshalAppStatus x-   | x == glut_APPSTATUS_PAUSE = AppStatusPause-   | x == glut_APPSTATUS_RESUME = AppStatusResume-   | otherwise = error ("unmarshalAppStatus: illegal value " ++ show x)-------------------------------------------------------------------------------------- | An application status callback--type AppStatusCallback = AppStatus -> IO ()---- | Controls the application status callback for the /current window./--appStatusCallback :: SettableStateVar (Maybe AppStatusCallback)-appStatusCallback = makeSettableStateVar $-   setCallback AppStatusCB glutAppStatusFunc-               (makeAppStatusFunc . unmarshal)-   where unmarshal cb  = cb . unmarshalAppStatus-------------------------------------------------------------------------------------- | A keyboard callback--type KeyboardCallback = Char -> Position -> IO ()--setKeyboardCallback :: Maybe KeyboardCallback -> IO ()-setKeyboardCallback =-   setCallback KeyboardCB glutKeyboardFunc (makeKeyboardFunc . unmarshal)-   where unmarshal cb c x y = cb (chr (fromIntegral c))-                                 (Position (fromIntegral x) (fromIntegral y))---- | Controls the keyboard callback for the /current window/. This is--- activated only when a key is pressed.--keyboardCallback :: SettableStateVar (Maybe KeyboardCallback)-keyboardCallback = makeSettableStateVar setKeyboardCallback------------------------------------------------------------------------------------setKeyboardUpCallback :: Maybe KeyboardCallback -> IO ()-setKeyboardUpCallback =-   setCallback KeyboardUpCB glutKeyboardUpFunc-               (makeKeyboardUpFunc . unmarshal)-   where unmarshal cb c x y = cb (chr (fromIntegral c))-                                 (Position (fromIntegral x) (fromIntegral y))---- | Controls the keyboard callback for the /current window/. This is--- activated only when a key is released.--keyboardUpCallback :: SettableStateVar (Maybe KeyboardCallback)-keyboardUpCallback = makeSettableStateVar setKeyboardUpCallback-------------------------------------------------------------------------------------- | Special keys--data SpecialKey-   = KeyF1-   | KeyF2-   | KeyF3-   | KeyF4-   | KeyF5-   | KeyF6-   | KeyF7-   | KeyF8-   | KeyF9-   | KeyF10-   | KeyF11-   | KeyF12-   | KeyLeft-   | KeyUp-   | KeyRight-   | KeyDown-   | KeyPageUp-   | KeyPageDown-   | KeyHome-   | KeyEnd-   | KeyInsert-   | KeyNumLock-   | KeyBegin-   | KeyDelete-   | KeyShiftL-   | KeyShiftR-   | KeyCtrlL-   | KeyCtrlR-   | KeyAltL-   | KeyAltR-   | KeyUnknown Int -- ^ You should actually never encounter this value, it is-                    -- just here as a safeguard against future changes in the-                    -- native GLUT library.-   deriving ( Eq, Ord, Show )--unmarshalSpecialKey :: CInt -> SpecialKey-unmarshalSpecialKey x-   | x == glut_KEY_F1 = KeyF1-   | x == glut_KEY_F2 = KeyF2-   | x == glut_KEY_F3 = KeyF3-   | x == glut_KEY_F4 = KeyF4-   | x == glut_KEY_F5 = KeyF5-   | x == glut_KEY_F6 = KeyF6-   | x == glut_KEY_F7 = KeyF7-   | x == glut_KEY_F8 = KeyF8-   | x == glut_KEY_F9 = KeyF9-   | x == glut_KEY_F10 = KeyF10-   | x == glut_KEY_F11 = KeyF11-   | x == glut_KEY_F12 = KeyF12-   | x == glut_KEY_LEFT = KeyLeft-   | x == glut_KEY_UP = KeyUp-   | x == glut_KEY_RIGHT = KeyRight-   | x == glut_KEY_DOWN = KeyDown-   | x == glut_KEY_PAGE_UP = KeyPageUp-   | x == glut_KEY_PAGE_DOWN = KeyPageDown-   | x == glut_KEY_HOME = KeyHome-   | x == glut_KEY_END = KeyEnd-   | x == glut_KEY_INSERT = KeyInsert-   | x == glut_KEY_NUM_LOCK = KeyNumLock-   | x == glut_KEY_BEGIN = KeyBegin-   | x == glut_KEY_DELETE = KeyDelete-   | x == glut_KEY_SHIFT_L = KeyShiftL-   | x == glut_KEY_SHIFT_R = KeyShiftR-   | x == glut_KEY_CTRL_L = KeyCtrlL-   | x == glut_KEY_CTRL_R = KeyCtrlR-   | x == glut_KEY_ALT_L = KeyAltL-   | x == glut_KEY_ALT_R = KeyAltR-   | otherwise = KeyUnknown (fromIntegral x)-------------------------------------------------------------------------------------- | A special key callback--type SpecialCallback = SpecialKey -> Position -> IO ()--setSpecialCallback :: Maybe SpecialCallback -> IO ()-setSpecialCallback =-   setCallback SpecialCB glutSpecialFunc (makeSpecialFunc . unmarshal)-   where unmarshal cb k x y = cb (unmarshalSpecialKey k)-                                 (Position (fromIntegral x) (fromIntegral y))---- | Controls the special key callback for the /current window/. This is--- activated only when a special key is pressed.--specialCallback :: SettableStateVar (Maybe SpecialCallback)-specialCallback = makeSettableStateVar setSpecialCallback------------------------------------------------------------------------------------setSpecialUpCallback :: Maybe SpecialCallback -> IO ()-setSpecialUpCallback =-   setCallback SpecialUpCB glutSpecialUpFunc (makeSpecialUpFunc . unmarshal)-   where unmarshal cb k x y = cb (unmarshalSpecialKey k)-                                 (Position (fromIntegral x) (fromIntegral y))---- | Controls the special key callback for the /current window/. This is--- activated only when a special key is released.--specialUpCallback :: SettableStateVar (Maybe SpecialCallback)-specialUpCallback = makeSettableStateVar setSpecialUpCallback-------------------------------------------------------------------------------------- | The current state of a key or button--data KeyState-   = Down-   | Up-   deriving ( Eq, Ord, Show )--unmarshalKeyState :: CInt -> KeyState-unmarshalKeyState x-   | x == glut_DOWN = Down-   | x == glut_UP = Up-   | otherwise = error ("unmarshalKeyState: illegal value " ++ show x)-------------------------------------------------------------------------------------- | A mouse callback--type MouseCallback = MouseButton -> KeyState -> Position -> IO ()--setMouseCallback :: Maybe MouseCallback -> IO ()-setMouseCallback =-   setCallback MouseCB glutMouseFunc (makeMouseFunc . unmarshal)-   where unmarshal cb b s x y = cb (unmarshalMouseButton b)-                                   (unmarshalKeyState s)-                                   (Position (fromIntegral x) (fromIntegral y))---- | Controls the mouse callback for the /current window/.--mouseCallback :: SettableStateVar (Maybe MouseCallback)-mouseCallback = makeSettableStateVar setMouseCallback-------------------------------------------------------------------------------------- | The state of the keyboard modifiers--data Modifiers = Modifiers { shift, ctrl, alt :: KeyState }-   deriving ( Eq, Ord, Show )---- Could use fromBitfield + Enum/Bounded instances + marshalModifier instead...-unmarshalModifiers :: CInt -> Modifiers-unmarshalModifiers m = Modifiers {-   shift = if (m .&. glut_ACTIVE_SHIFT) /= 0 then Down else Up,-   ctrl  = if (m .&. glut_ACTIVE_CTRL ) /= 0 then Down else Up,-   alt   = if (m .&. glut_ACTIVE_ALT  ) /= 0 then Down else Up }--getModifiers :: IO Modifiers-getModifiers = fmap unmarshalModifiers glutGetModifiers-------------------------------------------------------------------------------------- | A generalized view of keys--data Key-   = Char Char-   | SpecialKey SpecialKey-   | MouseButton MouseButton-   deriving ( Eq, Ord, Show )---- | A keyboard\/mouse callback--type KeyboardMouseCallback =-   Key -> KeyState -> Modifiers -> Position -> IO ()---- | Controls the keyboard\/mouse callback for the /current window./ The--- keyboard\/mouse callback for a window is called when the state of a key or--- mouse button changes. The callback parameters indicate the new state of the--- key\/button, the state of the keyboard modifiers, and the mouse location in--- window relative coordinates.------ Note that this is a convenience function that should not ordinarily be used--- in conjunction with `keyboardCallback`, `keyboardUpCallback`,--- `specialCallback`, `specialUpCallback`, or `mouseCallback`.--keyboardMouseCallback :: SettableStateVar (Maybe KeyboardMouseCallback)-keyboardMouseCallback = makeSettableStateVar setKeyboardMouseCallback--setKeyboardMouseCallback :: Maybe KeyboardMouseCallback -> IO ()-setKeyboardMouseCallback Nothing = do-   setKeyboardCallback   Nothing-   setKeyboardUpCallback Nothing-   setSpecialCallback    Nothing-   setSpecialUpCallback  Nothing-   setMouseCallback      Nothing-setKeyboardMouseCallback (Just cb) = do-   setKeyboardCallback   (Just (\c   p -> do m <- getModifiers-                                             cb (Char        c) Down m p))-   setKeyboardUpCallback (Just (\c   p -> do m <- getModifiers-                                             cb (Char        c) Up   m p))-   setSpecialCallback    (Just (\s   p -> do m <- getModifiers-                                             cb (SpecialKey  s) Down m p))-   setSpecialUpCallback  (Just (\s   p -> do m <- getModifiers-                                             cb (SpecialKey  s) Up   m p))-   setMouseCallback      (Just (\b s p -> do m <- getModifiers-                                             cb (MouseButton b) s    m p))------------------------------------------------------------------------------------type WheelNumber = Int--type WheelDirection = Int--type MouseWheelCallback = WheelNumber -> WheelDirection -> Position -> IO ()---- | (/freeglut only/) Controls the mouse wheel callback for the--- /current window./ The mouse wheel callback for a window is called when a--- mouse wheel is used and the wheel number is greater than or equal to--- 'Graphics.UI.GLUT.State.numMouseButtons'.--mouseWheelCallback :: SettableStateVar (Maybe MouseWheelCallback)-mouseWheelCallback = makeSettableStateVar $-   setCallback MouseWheelCB glutMouseWheelFunc (makeMouseWheelFunc . unmarshal)-   where unmarshal cb n d x y = cb (fromIntegral n) (fromIntegral d)-                                   (Position (fromIntegral x) (fromIntegral y))-------------------------------------------------------------------------------------- | A motion callback--type MotionCallback = Position -> IO ()---- | Controls the motion callback for the /current window./ The motion callback--- for a window is called when the mouse moves within the window while one or--- more mouse buttons are pressed. The callback parameter indicates the mouse--- location in window relative coordinates.--motionCallback :: SettableStateVar (Maybe MotionCallback)-motionCallback = makeSettableStateVar $-   setCallback MotionCB glutMotionFunc (makeMotionFunc . unmarshal)-   where unmarshal cb x y = cb (Position (fromIntegral x) (fromIntegral y))-------------------------------------------------------------------------------------- | Controls the passive motion callback for the /current window./ The passive--- motion callback for a window is called when the mouse moves within the window--- while /no/ mouse buttons are pressed. The callback parameter indicates the--- mouse location in window relative coordinates.--passiveMotionCallback :: SettableStateVar (Maybe MotionCallback)-passiveMotionCallback = makeSettableStateVar $-   setCallback PassiveMotionCB glutPassiveMotionFunc-               (makePassiveMotionFunc . unmarshal)-   where unmarshal cb x y = cb (Position (fromIntegral x) (fromIntegral y))-------------------------------------------------------------------------------------- | The relation between the mouse pointer and the /current window/ has--- changed.--data Crossing-   = WindowLeft    -- ^ The mouse pointer has left the /current window./-   | WindowEntered -- ^ The mouse pointer has entered the /current window./-   deriving ( Eq, Ord, Show )--unmarshalCrossing :: CInt -> Crossing-unmarshalCrossing x-   | x == glut_LEFT = WindowLeft-   | x == glut_ENTERED = WindowEntered-   | otherwise = error ("unmarshalCrossing: illegal value " ++ show x)-------------------------------------------------------------------------------------- | An enter\/leave callback--type CrossingCallback = Crossing -> IO ()---- | Controls the mouse enter\/leave callback for the /current window./ Note--- that some window systems may not generate accurate enter\/leave callbacks.------ /X Implementation Notes:/ An X implementation of GLUT should generate--- accurate enter\/leave callbacks.--crossingCallback :: SettableStateVar (Maybe CrossingCallback)-crossingCallback = makeSettableStateVar $-   setCallback CrossingCB glutEntryFunc (makeEntryFunc . unmarshal)-   where unmarshal cb = cb . unmarshalCrossing-------------------------------------------------------------------------------------- | Translation of the Spaceball along one axis, normalized to be in the range--- of -1000 to +1000 inclusive--type SpaceballMotion = Int---- | Rotation of the Spaceball along one axis, normalized to be in the range--- of -1800 .. +1800 inclusive--type SpaceballRotation = Int---- | The index of a specific buttons of an input device.--type ButtonIndex = Int---- | The state of the Spaceball has changed.--data SpaceballInput-   = SpaceballMotion   SpaceballMotion SpaceballMotion SpaceballMotion-   | SpaceballRotation SpaceballRotation SpaceballRotation SpaceballRotation-   | SpaceballButton   ButtonIndex KeyState-   deriving ( Eq, Ord, Show )---- | A SpaceballButton callback--type SpaceballCallback = SpaceballInput -> IO ()---- | Controls the Spaceball callback for the /current window./ The Spaceball--- callback for a window is called when the window has Spaceball input focus--- (normally, when the mouse is in the window) and the user generates Spaceball--- translations, rotations, or button presses. The number of available Spaceball--- buttons can be determined with 'Graphics.UI.GLUT.State.numSpaceballButtons'.------ Registering a Spaceball callback when a Spaceball device is not available has--- no effect and is not an error. In this case, no Spaceball callbacks will be--- generated.--spaceballCallback :: SettableStateVar (Maybe SpaceballCallback)-spaceballCallback = makeSettableStateVar setSpaceballCallback--setSpaceballCallback :: Maybe SpaceballCallback -> IO ()-setSpaceballCallback Nothing = do-   setSpaceballMotionCallback   Nothing-   setSpaceballRotationCallback Nothing-   setSpaceballButtonCallback   Nothing-setSpaceballCallback (Just cb) = do-   setSpaceballMotionCallback   (Just (\x y z -> cb (SpaceballMotion   x y z)))-   setSpaceballRotationCallback (Just (\x y z -> cb (SpaceballRotation x y z)))-   setSpaceballButtonCallback   (Just (\b s   -> cb (SpaceballButton   b s)))------------------------------------------------------------------------------------type SpaceballMotionCallback =-   SpaceballMotion -> SpaceballMotion -> SpaceballMotion -> IO ()--setSpaceballMotionCallback :: Maybe SpaceballMotionCallback -> IO ()-setSpaceballMotionCallback =-   setCallback SpaceballMotionCB glutSpaceballMotionFunc-               (makeSpaceballMotionFunc . unmarshal)-   where unmarshal cb x y z =-            cb (fromIntegral x) (fromIntegral y) (fromIntegral z)------------------------------------------------------------------------------------type SpaceballRotationCallback =-   SpaceballRotation -> SpaceballRotation -> SpaceballRotation -> IO ()--setSpaceballRotationCallback :: Maybe SpaceballRotationCallback -> IO ()-setSpaceballRotationCallback =-   setCallback SpaceballRotateCB glutSpaceballRotateFunc-               (makeSpaceballRotateFunc . unmarshal)-   where unmarshal cb x y z =-            cb (fromIntegral x) (fromIntegral y) (fromIntegral z)------------------------------------------------------------------------------------type SpaceballButtonCallback = ButtonIndex -> KeyState -> IO ()--setSpaceballButtonCallback :: Maybe SpaceballButtonCallback -> IO ()-setSpaceballButtonCallback =-   setCallback SpaceballButtonCB glutSpaceballButtonFunc-               (makeSpaceballButtonFunc . unmarshal)-   where unmarshal cb b s = cb (fromIntegral b) (unmarshalKeyState s)-------------------------------------------------------------------------------------- | The index of a specific dial of a dial and button box.--type DialIndex = Int---- | The dial & button box state has changed.--data DialAndButtonBoxInput-   = DialAndButtonBoxButton ButtonIndex KeyState-   | DialAndButtonBoxDial   DialIndex Int-   deriving ( Eq, Ord, Show )---- | A dial & button box callback--type DialAndButtonBoxCallback = DialAndButtonBoxInput -> IO ()---- | Controls the dial & button box callback for the /current window./ The dial--- & button box button callback for a window is called when the window has dial--- & button box input focus (normally, when the mouse is in the window) and the--- user generates dial & button box button presses or dial changes. The number--- of available dial & button box buttons and dials can be determined with--- 'Graphics.UI.GLUT.State.numDialsAndButtons'.------ Registering a dial & button box callback when a dial & button box device is--- not available is ineffectual and not an error. In this case, no dial & button--- box button will be generated.--dialAndButtonBoxCallback :: SettableStateVar (Maybe DialAndButtonBoxCallback)-dialAndButtonBoxCallback = makeSettableStateVar setDialAndButtonBoxCallback--setDialAndButtonBoxCallback :: Maybe DialAndButtonBoxCallback -> IO ()-setDialAndButtonBoxCallback Nothing = do-   setButtonBoxCallback Nothing-   setDialsCallback     Nothing-setDialAndButtonBoxCallback (Just cb) = do-   setButtonBoxCallback (Just (\b s -> cb (DialAndButtonBoxButton b s)))-   setDialsCallback     (Just (\d x -> cb (DialAndButtonBoxDial   d x)))------------------------------------------------------------------------------------type ButtonBoxCallback = ButtonIndex -> KeyState -> IO ()--setButtonBoxCallback :: Maybe ButtonBoxCallback -> IO ()-setButtonBoxCallback =-   setCallback ButtonBoxCB glutButtonBoxFunc (makeButtonBoxFunc . unmarshal)-   where unmarshal cb b s = cb (fromIntegral b) (unmarshalKeyState s)------------------------------------------------------------------------------------type DialsCallback = DialIndex -> Int -> IO ()--setDialsCallback :: Maybe DialsCallback -> IO ()-setDialsCallback =-    setCallback DialsCB glutDialsFunc (makeDialsFunc . unmarshal)-    where unmarshal cb d x = cb (fromIntegral d) (fromIntegral x)-------------------------------------------------------------------------------------- | Absolute tablet position, with coordinates normalized to be in the range of--- 0 to 2000 inclusive--data TabletPosition = TabletPosition Int Int-   deriving ( Eq, Ord, Show )---- | The table state has changed.--data TabletInput-   = TabletMotion-   | TabletButton ButtonIndex KeyState-   deriving ( Eq, Ord, Show )---- | A tablet callback--type TabletCallback = TabletInput -> TabletPosition -> IO ()---- | Controls the tablet callback for the /current window./ The tablet callback--- for a window is called when the window has tablet input focus (normally, when--- the mouse is in the window) and the user generates tablet motion or button--- presses. The number of available tablet buttons can be determined with--- 'Graphics.UI.GLUT.State.numTabletButtons'.------ Registering a tablet callback when a tablet device is not available is--- ineffectual and not an error. In this case, no tablet callbacks will be--- generated.--tabletCallback :: SettableStateVar (Maybe TabletCallback)-tabletCallback = makeSettableStateVar setTabletCallback--setTabletCallback :: Maybe TabletCallback -> IO ()-setTabletCallback Nothing = do-   setTabletMotionCallback Nothing-   setTabletButtonCallback Nothing-setTabletCallback (Just cb) = do-   setTabletMotionCallback (Just (\p     -> cb TabletMotion       p))-   setTabletButtonCallback (Just (\b s p -> cb (TabletButton b s) p))------------------------------------------------------------------------------------type TabletMotionCallback = TabletPosition -> IO ()--setTabletMotionCallback :: Maybe TabletMotionCallback -> IO ()-setTabletMotionCallback =-    setCallback TabletMotionCB glutTabletMotionFunc-                (makeTabletMotionFunc . unmarshal)-    where unmarshal cb x y =-             cb (TabletPosition (fromIntegral x) (fromIntegral y))------------------------------------------------------------------------------------type TabletButtonCallback = ButtonIndex -> KeyState -> TabletPosition -> IO ()--setTabletButtonCallback :: Maybe TabletButtonCallback -> IO ()-setTabletButtonCallback =-    setCallback TabletButtonCB glutTabletButtonFunc-                (makeTabletButtonFunc . unmarshal)-    where unmarshal cb b s x y =-             cb (fromIntegral b) (unmarshalKeyState s)-                (TabletPosition (fromIntegral x) (fromIntegral y))-------------------------------------------------------------------------------------- | The state of the joystick buttons--data JoystickButtons = JoystickButtons {-   joystickButtonA, joystickButtonB,-   joystickButtonC, joystickButtonD :: KeyState }-   deriving ( Eq, Ord, Show )---- Could use fromBitfield + Enum/Bounded instances + unmarshalJoystickButton--- instead...-unmarshalJoystickButtons :: CUInt -> JoystickButtons-unmarshalJoystickButtons m = JoystickButtons {-   joystickButtonA = if (m .&. glut_JOYSTICK_BUTTON_A) /= 0 then Down else Up,-   joystickButtonB = if (m .&. glut_JOYSTICK_BUTTON_B) /= 0 then Down else Up,-   joystickButtonC = if (m .&. glut_JOYSTICK_BUTTON_C) /= 0 then Down else Up,-   joystickButtonD = if (m .&. glut_JOYSTICK_BUTTON_D) /= 0 then Down else Up }-------------------------------------------------------------------------------------- | Absolute joystick position, with coordinates normalized to be in the range--- of -1000 to 1000 inclusive. The signs of the three axes mean the following:------ * negative = left, positive = right------ * negative = towards player, positive = away------ * if available (e.g. rudder): negative = down, positive = up--data JoystickPosition = JoystickPosition Int Int Int-   deriving ( Eq, Ord, Show )-------------------------------------------------------------------------------------- | A joystick callback--type JoystickCallback = JoystickButtons -> JoystickPosition -> IO ()---- | Controls the joystick callback for the /current window./ The joystick--- callback is called either due to polling of the joystick at the uniform timer--- interval specified (if > 0) or in response to an explicit call of--- 'Graphics.UI.GLUT.DeviceControl.forceJoystickCallback'.------ /X Implementation Notes:/ Currently GLUT has no joystick support for X11.---- joystickCallback :: SettableStateVar (Maybe JoystickCallback, PollRate)-joystickCallback :: SettableStateVar (Maybe (JoystickCallback, PollRate))-joystickCallback =-   makeSettableStateVar $ \maybeCBAndRate ->-      setCallback JoystickCB-                  (\f -> glutJoystickFunc f (fromIntegral (snd (fromJust maybeCBAndRate))))-                  (makeJoystickFunc . unmarshal)-                  (fmap fst maybeCBAndRate)-    where unmarshal cb b x y z = cb (unmarshalJoystickButtons b)-                                    (JoystickPosition (fromIntegral x)-                                                      (fromIntegral y)-                                                      (fromIntegral z))-------------------------------------------------------------------------------------- | A description where the multi-touch event is coming from, the freeglut--- specs are very vague about the actual semantics. It contains the device ID--- and\/or the cursor\/finger ID.--type TouchID = Int---- | A multi-touch variant of 'MouseCallback'.--type MultiMouseCallback = TouchID -> MouseCallback---- | (/freeglut only/) A multi-touch variant of 'mouseCallback'.--multiMouseCallback :: SettableStateVar (Maybe MultiMouseCallback)-multiMouseCallback = makeSettableStateVar $-   setCallback MultiButtonCB glutMultiButtonFunc (makeMultiButtonFunc . unmarshal)-   where unmarshal cb d x y b s = cb (fromIntegral d)-                                     (unmarshalMouseButton b)-                                     (unmarshalKeyState s)-                                     (Position (fromIntegral x) (fromIntegral y))---- | A multi-touch variant of 'CrossingCallback'.--type MultiCrossingCallback = TouchID -> CrossingCallback---- | (/freeglut only/) A multi-touch variant of 'crossingCallback'.--multiCrossingCallback :: SettableStateVar (Maybe MultiCrossingCallback)-multiCrossingCallback = makeSettableStateVar $-   setCallback MultiEntryCB glutMultiEntryFunc (makeMultiEntryFunc . unmarshal)-   where unmarshal cb d c = cb (fromIntegral d) (unmarshalCrossing c)---- | A multi-touch variant of 'MotionCallback'.--type MultiMotionCallback = TouchID -> MotionCallback---- | (/freeglut only/) A multi-touch variant of 'motionCallback'.--multiMotionCallback :: SettableStateVar (Maybe MultiMotionCallback)-multiMotionCallback = makeSettableStateVar $-   setCallback MultiMotionCB glutMultiMotionFunc (makeMultiMotionFunc . unmarshal)-   where unmarshal cb d x y =-            cb (fromIntegral d) (Position (fromIntegral x) (fromIntegral y))---- | (/freeglut only/) A multi-touch variant of 'passiveMotionCallback'.--multiPassiveMotionCallback :: SettableStateVar (Maybe MultiMotionCallback)-multiPassiveMotionCallback = makeSettableStateVar $-   setCallback MultiPassiveCB glutMultiPassiveFunc (makeMultiPassiveFunc . unmarshal)-   where unmarshal cb d x y =-            cb (fromIntegral d) (Position (fromIntegral x) (fromIntegral y))
− Graphics/UI/GLUT/Colormap.hs 
@@ -1,110 +0,0 @@------------------------------------------------------------------------------------ |--- Module      :  Graphics.UI.GLUT.Colormap--- Copyright   :  (c) Sven Panne 2002-2013--- License     :  BSD3------ Maintainer  :  Sven Panne <svenpanne@gmail.com>--- Stability   :  stable--- Portability :  portable------ OpenGL supports both RGBA and color index rendering. The RGBA mode is--- generally preferable to color index because more OpenGL rendering--- capabilities are available and color index mode requires the loading of--- colormap entries.------ The GLUT color index state variables are used to read and write entries in a--- window\'s color index colormap. Every GLUT color index window has its own--- logical color index colormap. The size of a window\'s colormap can be--- determined by reading 'numColorMapEntries'.------ GLUT color index windows within a program can attempt to share colormap--- resources by copying a single color index colormap to multiple windows using--- 'copyColormap'. If possible GLUT will attempt to share the actual colormap.--- While copying colormaps using 'copyColormap' can potentially allow sharing of--- physical colormap resources, logically each window has its own colormap. So--- changing a copied colormap of a window will force the duplication of the--- colormap. For this reason, color index programs should generally load a--- single color index colormap, copy it to all color index windows within the--- program, and then not modify any colormap cells.------ Use of multiple colormaps is likely to result in colormap installation--- problems where some windows are displayed with an incorrect colormap due to--- limitations on colormap resources.--------------------------------------------------------------------------------------module Graphics.UI.GLUT.Colormap (-   colorMapEntry,-   copyColormap,-   numColorMapEntries,-   transparentIndex-) where--import Foreign.C.Types-import Graphics.Rendering.OpenGL ( GLfloat, GLint, Color3(..), Index1(..)-                                 , StateVar, makeStateVar, GettableStateVar-                                 , makeGettableStateVar )-import Graphics.UI.GLUT.QueryUtils-import Graphics.UI.GLUT.Raw-import Graphics.UI.GLUT.Types-------------------------------------------------------------------------------------- | Controls the color index colormap entry of the /current window/\'s logical--- colormap for the /layer in use/. The /layer in use/ of the /current window/--- should be a color index window. The color index should be zero or greater and--- less than the total number of colormap entries for the window (see--- 'numColorMapEntries') and different from an overlay\'s transparent index (see--- 'transparentIndex').------ If the /layer in use/\'s colormap was copied by reference, setting a colormap--- entry will force the duplication of the colormap.--colorMapEntry :: Index1 GLint -> StateVar (Color3 GLfloat)-colorMapEntry (Index1 cell) =-   makeStateVar (getColorMapEntry (fromIntegral cell))-                (setColorMapEntry (fromIntegral cell))--setColorMapEntry :: CInt -> Color3 GLfloat -> IO ()-setColorMapEntry cell (Color3 r g b) = glutSetColor cell r g b--getColorMapEntry :: CInt -> IO (Color3 GLfloat)-getColorMapEntry cell = do-   r <- glutGetColor cell glut_RED-   g <- glutGetColor cell glut_GREEN-   b <- glutGetColor cell glut_BLUE-   return $ Color3 r g b-------------------------------------------------------------------------------------- | Copy (lazily if possible to promote sharing) the logical colormap from a--- specified window to the /current window/\'s /layer in use/. The copy will be--- from the normal plane to the normal plane; or from the overlay to the overlay--- (never across different layers). Once a colormap has been copied, avoid--- setting cells in the colormap via 'colorMapEntry' since that will force an--- actual copy of the colormap if it was previously copied by reference.--- 'copyColormap' should only be called when both the /current window/ and the--- specified window are color index windows.--copyColormap :: Window -> IO ()-copyColormap (Window win) = glutCopyColormap win-------------------------------------------------------------------------------------- | Contains the number of entries in the colormap of the /current window/\'s--- current layer (0 in RGBA mode).--numColorMapEntries :: GettableStateVar GLint-numColorMapEntries =-   makeGettableStateVar $ simpleGet fromIntegral glut_WINDOW_COLORMAP_SIZE-------------------------------------------------------------------------------------- | Contains the transparent color index of the overlay of the /current window/--- or -1 if no overlay is in use.--transparentIndex :: GettableStateVar (Index1 GLint)-transparentIndex =-   makeGettableStateVar $-      layerGet (Index1 . fromIntegral) glut_TRANSPARENT_INDEX
− Graphics/UI/GLUT/Debugging.hs 
@@ -1,37 +0,0 @@------------------------------------------------------------------------------------ |--- Module      :  Graphics.UI.GLUT.Debugging--- Copyright   :  (c) Sven Panne 2002-2013--- License     :  BSD3------ Maintainer  :  Sven Panne <svenpanne@gmail.com>--- Stability   :  stable--- Portability :  portable------ This module contains a simple utility routine to report any pending GL--- errors.--------------------------------------------------------------------------------------module Graphics.UI.GLUT.Debugging (-   reportErrors-) where--import Graphics.Rendering.OpenGL ( Error(..), errors, get )-import System.Environment-import System.IO-------------------------------------------------------------------------------------- | Report any pending GL errors to stderr (which is typically the console).--- If there are no pending errors, this routine does nothing. Note that the--- error flags are reset after this action, i.e. there are no pending errors--- left afterwards.--reportErrors :: IO ()-reportErrors = get errors >>= mapM_ reportError--reportError :: Error -> IO ()-reportError (Error _ msg) = do-   pn <- getProgName-   hPutStrLn stderr ("GLUT: Warning in " ++ pn ++ ": GL error: " ++ msg)
− Graphics/UI/GLUT/DeviceControl.hs 
@@ -1,122 +0,0 @@------------------------------------------------------------------------------------ |--- Module      :  Graphics.UI.GLUT.DeviceControl--- Copyright   :  (c) Sven Panne 2002-2013--- License     :  BSD3------ Maintainer  :  Sven Panne <svenpanne@gmail.com>--- Stability   :  stable--- Portability :  portable------ GLUT offers some routines for controlling the key repeat and polling the--- joystick.--------------------------------------------------------------------------------------module Graphics.UI.GLUT.DeviceControl (-   GlobalKeyRepeat(..), globalKeyRepeat,-   PerWindowKeyRepeat(..), perWindowKeyRepeat,-   forceJoystickCallback-) where--import Foreign.C.Types-import Graphics.Rendering.OpenGL ( StateVar, makeStateVar )-import Graphics.UI.GLUT.QueryUtils-import Graphics.UI.GLUT.Raw-------------------------------------------------------------------------------------- | The state of the global key repeat--data GlobalKeyRepeat-   = GlobalKeyRepeatOff-   | GlobalKeyRepeatOn-   | GlobalKeyRepeatDefault-   deriving ( Eq, Ord, Show )--marshalGlobalKeyRepeat :: GlobalKeyRepeat -> CInt-marshalGlobalKeyRepeat x = case x of-   GlobalKeyRepeatOff -> glut_KEY_REPEAT_OFF-   GlobalKeyRepeatOn -> glut_KEY_REPEAT_ON-   GlobalKeyRepeatDefault -> glut_KEY_REPEAT_DEFAULT--unmarshalGlobalKeyRepeat :: CInt -> GlobalKeyRepeat-unmarshalGlobalKeyRepeat x-   | x == glut_KEY_REPEAT_OFF = GlobalKeyRepeatOff-   | x == glut_KEY_REPEAT_ON = GlobalKeyRepeatOn-   | x == glut_KEY_REPEAT_DEFAULT = GlobalKeyRepeatDefault-   | otherwise = error ("unmarshalGlobalKeyRepeat: illegal value " ++ show x)-------------------------------------------------------------------------------------- | Controls the key repeat mode for the window system on a global basis if--- possible. If supported by the window system, the key repeat can either be--- disabled, enabled, or set to the window system\'s default key repeat state.------ /X Implementation Notes:/ X11 sends @KeyPress@ events repeatedly when the--- window system\'s global auto repeat is enabled. 'perWindowKeyRepeat' can--- prevent these auto repeated keystrokes from being reported as keyboard or--- special callbacks, but there is still some minimal overhead by the X server--- to continually stream @KeyPress@ events to the GLUT application. The--- 'globalKeyRepeat' state variable can be used to actually disable the global--- sending of auto repeated @KeyPress@ events. Note that 'globalKeyRepeat'--- affects the global window system auto repeat state so other applications--- will not auto repeat if you disable auto repeat globally through--- 'globalKeyRepeat'. GLUT applications using the X11 GLUT implementation--- should disable key repeat with 'globalKeyRepeat' to disable key repeats most--- efficiently, but are responsible for explicitly restoring the default key--- repeat state on exit.------ /Win32 Implementation Notes:/ The Win32 implementation of 'globalKeyRepeat'--- does nothing. The 'perWindowKeyRepeat' can be used in the Win32 GLUT--- implementation to ignore repeated keys on a per-window basis without changing--- the global window system key repeat.--globalKeyRepeat :: StateVar GlobalKeyRepeat-globalKeyRepeat =-   makeStateVar (deviceGet unmarshalGlobalKeyRepeat glut_DEVICE_KEY_REPEAT)-                (glutSetKeyRepeat . marshalGlobalKeyRepeat)-------------------------------------------------------------------------------------- | The state of the per-window key repeat--data PerWindowKeyRepeat-   = PerWindowKeyRepeatOff-   | PerWindowKeyRepeatOn-   deriving ( Eq, Ord, Show )--marshalPerWindowKeyRepeat :: PerWindowKeyRepeat -> CInt-marshalPerWindowKeyRepeat x = case x of-   PerWindowKeyRepeatOn -> 0-   PerWindowKeyRepeatOff -> 1--unmarshalPerWindowKeyRepeat :: CInt -> PerWindowKeyRepeat-unmarshalPerWindowKeyRepeat x-   | x == 0 = PerWindowKeyRepeatOn-   | otherwise = PerWindowKeyRepeatOff-------------------------------------------------------------------------------------- | Controls if auto repeat keystrokes are reported to the /current window./--- Ignoring auto repeated keystrokes is generally done in conjunction with using--- the 'Graphics.UI.GLUT.Callbacks.Window.keyboardMouseCallback'. If you do--- not ignore auto repeated keystrokes, your GLUT application will experience--- repeated release\/press callbacks. Games using the keyboard will typically--- want to ignore key repeat.--perWindowKeyRepeat :: StateVar PerWindowKeyRepeat-perWindowKeyRepeat =-   makeStateVar-      (deviceGet unmarshalPerWindowKeyRepeat glut_DEVICE_IGNORE_KEY_REPEAT)-      (glutIgnoreKeyRepeat . marshalPerWindowKeyRepeat)-------------------------------------------------------------------------------------- | Execute the joystick callback set by--- 'Graphics.UI.GLUT.Callbacks.Window.joystickCallback' once (if one exists).--- This is done in a synchronous fashion within the current context, i.e. when--- 'forceJoystickCallback' returns, the callback will have already happened.--forceJoystickCallback :: IO ()-forceJoystickCallback = glutForceJoystickFunc
− Graphics/UI/GLUT/Fonts.hs 
@@ -1,120 +0,0 @@------------------------------------------------------------------------------------ |--- Module      :  Graphics.UI.GLUT.Fonts--- Copyright   :  (c) Sven Panne 2002-2013--- License     :  BSD3------ Maintainer  :  Sven Panne <svenpanne@gmail.com>--- Stability   :  stable--- Portability :  portable------ GLUT supports two types of font rendering: stroke fonts, meaning each--- character is rendered as a set of line segments; and bitmap fonts, where each--- character is a bitmap generated with--- 'Graphics.Rendering.OpenGL.GL.Bitmaps.bitmap'. Stroke fonts have the--- advantage that because they are geometry, they can be arbitrarily scale and--- rendered. Bitmap fonts are less flexible since they are rendered as bitmaps--- but are usually faster than stroke fonts.--------------------------------------------------------------------------------------module Graphics.UI.GLUT.Fonts (-   Font(..), BitmapFont(..), StrokeFont(..),-) where--import Data.Char-import Foreign.C.String-import Foreign.C.Types-import Foreign.Ptr-import Graphics.Rendering.OpenGL-import Graphics.UI.GLUT.Raw------------------------------------------------------------------------------------class Font a where-   -- | Render the string in the named font, without using any display lists.-   -- Rendering a nonexistent character has no effect.-   ---   -- If the font is a bitmap font, 'renderString' automatically sets the OpenGL-   -- unpack pixel storage modes it needs appropriately and saves and restores-   -- the previous modes before returning. The generated call to-   -- 'Graphics.Rendering.OpenGL.GL.bitmap' will adjust the current raster-   -- position based on the width of the string.-   -- If the font is a stroke font,-   -- 'Graphics.Rendering.OpenGL.GL.CoordTrans.translate' is used to translate-   -- the current model view matrix to advance the width of the string.--   renderString :: a -> String -> IO ()--   -- | For a bitmap font, return the width in pixels of a string. For a stroke-   -- font, return the width in units. While the width of characters in a font-   -- may vary (though fixed width fonts do not vary), the maximum height-   -- characteristics of a particular font are fixed.--   stringWidth :: a -> String -> IO GLint--   -- | (/freeglut only/) For a bitmap font, return the maximum height of the-   -- characters in the given font measured in pixels. For a stroke font,-   -- return the width in units.--   fontHeight :: a -> IO GLfloat--instance Font BitmapFont where-   renderString = bitmapString-   stringWidth  = bitmapLength-   fontHeight   = bitmapHeight---instance Font StrokeFont where-   renderString = strokeString-   stringWidth  = strokeLength-   fontHeight   = strokeHeight------------------------------------------------------------------------------------bitmapString :: BitmapFont -> String -> IO ()-bitmapString f s = do-   i <- marshalBitmapFont f-   mapM_ (\c -> withChar c (glutBitmapCharacter i)) s--withChar :: Char -> (CInt -> IO a) -> IO a-withChar c f = f . fromIntegral . ord $ c------------------------------------------------------------------------------------strokeString :: StrokeFont -> String -> IO ()-strokeString f s = do-   i <- marshalStrokeFont f-   mapM_ (\c -> withChar c (glutStrokeCharacter i)) s------------------------------------------------------------------------------------bitmapLength :: BitmapFont -- ^ Bitmap font to use.-             -> String     -- ^ String to return width of (not confined to 8-                           --   bits).-             -> IO GLint   -- ^ Width in pixels.-bitmapLength f s = do-   i <- marshalBitmapFont f-   fmap fromIntegral $ withCString s (glutBitmapLength i . castPtr)------------------------------------------------------------------------------------strokeLength :: StrokeFont -- ^ Stroke font to use.-             -> String     -- ^ String to return width of (not confined to 8-                           --   bits).-             -> IO GLint   -- ^ Width in units.-strokeLength f s = do-   i <- marshalStrokeFont f-   fmap fromIntegral $ withCString s (glutStrokeLength i . castPtr)------------------------------------------------------------------------------------bitmapHeight :: BitmapFont -- ^ Bitmap font to use.-             -> IO GLfloat -- ^ Height in pixels.-bitmapHeight f = fmap fromIntegral $ glutBitmapHeight =<< marshalBitmapFont f------------------------------------------------------------------------------------strokeHeight :: StrokeFont -- ^ Stroke font to use.-             -> IO GLfloat -- ^ Height in units.-strokeHeight f = glutStrokeHeight =<< marshalStrokeFont f
− Graphics/UI/GLUT/GameMode.hs 
@@ -1,191 +0,0 @@------------------------------------------------------------------------------------ |--- Module      :  Graphics.UI.GLUT.GameMode--- Copyright   :  (c) Sven Panne 2002-2013--- License     :  BSD3------ Maintainer  :  Sven Panne <svenpanne@gmail.com>--- Stability   :  stable--- Portability :  portable------ In addition to the functionality offered by--- 'Graphics.UI.GLUT.Window.fullScreen', GLUT offers an sub-API to change the--- screen resolution, color depth, and refresh rate of the display for a single--- full screen window. This mode of operation is called /game mode/, and is--- restricted in various ways: No pop-up menus are allowed for this full screen--- window, no other (sub-)windows can be created, and all other applications are--- hidden.------ /X Implementation Notes:/ Note that game mode is not fully supported in the--- original GLUT for X, it is essentially the same as using--- 'Graphics.UI.GLUT.Window.fullScreen'. The GLUT clone freeglut--- (see <http://freeglut.sourceforge.net/>) does not have this restriction.--------------------------------------------------------------------------------------module Graphics.UI.GLUT.GameMode (-   GameModeCapability(..), GameModeCapabilityDescription(..),-   gameModeCapabilities, enterGameMode, leaveGameMode,-   BitsPerPlane, RefreshRate, GameModeInfo(..), gameModeInfo,-   gameModeActive-) where--import Data.List-import Foreign.C.String-import Graphics.Rendering.OpenGL ( GLenum, Size(..)-                                 , GettableStateVar-                                 , SettableStateVar-                                 , makeGettableStateVar-                                 , makeSettableStateVar )-import Graphics.UI.GLUT.Raw-import Graphics.UI.GLUT.Types-------------------------------------------------------------------------------------- | Capabilities for 'gameModeCapabilities'--data GameModeCapability-   = GameModeWidth         -- ^ Width of the screen resolution in pixels-   | GameModeHeight        -- ^ Height of the screen resolution in pixels-   | GameModeBitsPerPlane  -- ^ Color depth of the screen in bits-   | GameModeRefreshRate   -- ^ Refresh rate in Hertz-   | GameModeNum           -- ^ Match the Nth frame buffer configuration-                           --   compatible with the given capabilities-                           --   (numbering starts at 1)-   deriving ( Eq, Ord, Show )--gameModeCapabilityToString :: GameModeCapability -> String-gameModeCapabilityToString x = case x of-   GameModeWidth        -> "width"-   GameModeHeight       -> "height"-   GameModeBitsPerPlane -> "bpp"-   GameModeRefreshRate  -> "hertz"-   GameModeNum          -> "num"---- | A single capability description for 'gameModeCapabilities'.--data GameModeCapabilityDescription = Where' GameModeCapability Relation Int-   deriving ( Eq, Ord, Show )--gameModeCapabilityDescriptionToString :: GameModeCapabilityDescription -> String-gameModeCapabilityDescriptionToString (Where' c r i) =-      gameModeCapabilityToString c ++ relationToString r ++ show i-------------------------------------------------------------------------------------- | Controls the /game mode/ to be used when 'enterGameMode' is called. It is--- described by a list of zero or more capability descriptions, which are--- translated into a set of criteria used to select the appropriate screen--- configuration. The criteria are matched in strict left to right order of--- precdence. That is, the first specified criterion (leftmost) takes precedence--- over the later criteria for non-exact criteria--- ('Graphics.UI.GLUT.Initialization.IsGreaterThan',--- 'Graphics.UI.GLUT.Initialization.IsLessThan', etc.). Exact criteria--- ('Graphics.UI.GLUT.Initialization.IsEqualTo',--- 'Graphics.UI.GLUT.Initialization.IsNotEqualTo') must match exactly so--- precedence is not relevant.------ To determine which configuration will actually be tried by 'enterGameMode'--- (if any), use 'gameModeInfo'.------ Note that even for game mode the current values of--- 'Graphics.UI.GLUT.Initialization.initialDisplayMode'or--- 'Graphics.UI.GLUT.Initialization.initialDisplayCapabilities' will--- determine which buffers are available, if double buffering is used or not,--- etc.--gameModeCapabilities :: SettableStateVar [GameModeCapabilityDescription]-gameModeCapabilities = makeSettableStateVar $ \ds ->-   withCString (descriptionsToString ds) glutGameModeString---- freeglut currently handles only simple game mode descriptions like "WxH:B@R",--- so we try hard to use this format instead of the more general format allowed--- by the "real" GLUT.-descriptionsToString :: [GameModeCapabilityDescription] -> String-descriptionsToString ds =-   let ws = [ x | Where' GameModeWidth        IsEqualTo x <- ds ]-       hs = [ x | Where' GameModeHeight       IsEqualTo x <- ds ]-       bs = [ x | Where' GameModeBitsPerPlane IsEqualTo x <- ds ]-       rs = [ x | Where' GameModeRefreshRate  IsEqualTo x <- ds ]-       allSimple = (length ws + length hs + length bs + length rs) == (length ds)-       dimensionsOK = (null ws) == (null hs)-   in if allSimple && dimensionsOK-         then simpleCapStr ws hs bs rs-         else generalCapStr ds--simpleCapStr :: [Int] -> [Int] -> [Int] -> [Int] -> String-simpleCapStr ws hs bs rs =-   showCap "" ws ++ showCap "x" hs ++ showCap ":" bs ++ showCap "@" rs-   where showCap _      []    = ""-         showCap prefix (x:_) = prefix ++ show x--generalCapStr :: [GameModeCapabilityDescription] -> String-generalCapStr =-   concat . intersperse " " . map gameModeCapabilityDescriptionToString-------------------------------------------------------------------------------------- | Enter /game mode/, trying to change resolution, refresh rate, etc., as--- specified by the current value of 'gameModeCapabilities'. An identifier for--- the game mode window and a flag, indicating if the display mode actually--- changed, are returned. The game mode window is made the /current window/.------ Re-entering /game mode/ is allowed, the previous game mode window gets--- destroyed by this, and a new one is created.--enterGameMode :: IO (Window, Bool)-enterGameMode = do-   w <- glutEnterGameMode-   c <- getBool glut_GAME_MODE_DISPLAY_CHANGED-   return (Window w, c)-------------------------------------------------------------------------------------- | Leave /game mode/, restoring the old display mode and destroying the game--- mode window.--leaveGameMode :: IO ()-leaveGameMode = glutLeaveGameMode-------------------------------------------------------------------------------------- | The color depth of the screen, measured in bits (e.g. 8, 16, 24, 32, ...)--type BitsPerPlane = Int---- | The refresh rate of the screen, measured in Hertz (e.g. 60, 75, 100, ...)--type RefreshRate = Int--data GameModeInfo = GameModeInfo Size BitsPerPlane RefreshRate-   deriving ( Eq, Ord, Show )-------------------------------------------------------------------------------------- | Return 'Just' the mode which would be tried by the next call to--- 'enterGameMode'. Returns 'Nothing' if the mode requested by the current value--- of 'gameModeCapabilities' is not possible, in which case 'enterGameMode'--- would simply create a full screen window using the current mode.--gameModeInfo :: GettableStateVar (Maybe GameModeInfo)-gameModeInfo = makeGettableStateVar $ do-   possible <- getBool glut_GAME_MODE_POSSIBLE-   if possible-      then do-         w <- glutGameModeGet glut_GAME_MODE_WIDTH-         h <- glutGameModeGet glut_GAME_MODE_HEIGHT-         let size = Size (fromIntegral w) (fromIntegral h)-         b <- glutGameModeGet glut_GAME_MODE_PIXEL_DEPTH-         r <- glutGameModeGet glut_GAME_MODE_REFRESH_RATE-         return $ Just $ GameModeInfo size (fromIntegral b) (fromIntegral r)-      else return Nothing--getBool :: GLenum -> IO Bool-getBool = fmap (/= 0) . glutGameModeGet-------------------------------------------------------------------------------------- | Contains 'True' when the /game mode/ is active, 'False' otherwise.--gameModeActive :: GettableStateVar Bool-gameModeActive = makeGettableStateVar $ getBool glut_GAME_MODE_ACTIVE
− Graphics/UI/GLUT/Initialization.hs 
@@ -1,773 +0,0 @@------------------------------------------------------------------------------------ |--- Module      :  Graphics.UI.GLUT.Initialization--- Copyright   :  (c) Sven Panne 2002-2013--- License     :  BSD3------ Maintainer  :  Sven Panne <svenpanne@gmail.com>--- Stability   :  stable--- Portability :  portable------ Actions and state variables in this module are used to initialize GLUT state.--- The primary initialization routine is 'initialize', which should only be--- called exactly once in a GLUT program. No other GLUT or OpenGL actions should--- be called before 'initialize', apart from getting or setting the state--- variables in this module.------ The reason is that these state variables can be used to set default window--- initialization state that might be modified by the command processing done in--- 'initialize'. For example, 'initialWindowSize' can be set to @('Size'--- 400 400)@ before 'initialize' is called to indicate 400 by 400 is the--- program\'s default window size. Setting the initial window size or position--- before 'initialize' allows the GLUT program user to specify the initial size--- or position using command line arguments.--------------------------------------------------------------------------------------module Graphics.UI.GLUT.Initialization (-   -- * Primary initialization-   initialize, getArgsAndInitialize, exit,--   -- * Initial window geometry-   initialWindowPosition, initialWindowSize,--   -- * Setting the initial display mode (I)-   DisplayMode(..), initialDisplayMode, displayModePossible,--   -- * Setting the initial display mode (II)-   DisplayCapability(..), Relation(..), DisplayCapabilityDescription(..),-   initialDisplayCapabilities,--   -- * Controlling the creation of rendering contexts-   RenderingContext(..), renderingContext,--   -- * Direct\/indirect rendering-   DirectRendering(..), directRendering,--   -- * OpenGL 3.x context support-   initialContextVersion, ContextFlag(..), initialContextFlags,-   ContextProfile(..), initialContextProfile-) where--import Control.Monad-import Data.Bits-import Data.List-import Foreign.C.String-import Foreign.C.Types-import Foreign.Marshal.Array-import Foreign.Marshal.Utils-import Foreign.Ptr-import Foreign.Storable-import Graphics.Rendering.OpenGL ( Position(..), Size(..)-                                 , StateVar, GettableStateVar, get-                                 , SettableStateVar, makeStateVar, ($=)-                                 , makeGettableStateVar-                                 , makeSettableStateVar )-import Graphics.UI.GLUT.QueryUtils-import Graphics.UI.GLUT.Raw-import Graphics.UI.GLUT.Types-import System.Environment-------------------------------------------------------------------------------------- | Given the program name and command line arguments, initialize the GLUT--- library and negotiate a session with the window system. During this--- process, 'initialize' may cause the termination of the GLUT program with an--- error message to the user if GLUT cannot be properly initialized.--- Examples of this situation include the failure to connect to the window--- system, the lack of window system support for OpenGL, and invalid command--- line options.------ 'initialize' also processes command line options, but the specific options--- parsed are window system dependent. Any command line arguments which are--- not GLUT-specific are returned.------ /X Implementation Notes:/ The X Window System specific options parsed by--- 'initialize' are as follows:------ * @-display /DISPLAY/@: Specify the X server to connect to. If not specified,---   the value of the @DISPLAY@ environment variable is used.------ * @-geometry /WxH+X+Y/@: Determines where windows should be created on the---   screen. The parameter following @-geometry@ should be formatted as a---   standard X geometry specification. The effect of using this option is to---   change the GLUT initial size and initial position the same as if---   'initialWindowSize' or 'initialWindowPosition' were modified directly.------ * @-iconic@: Requests all top-level windows be created in an iconic state.------ * @-indirect@: Force the use of indirect OpenGL rendering contexts.------ * @-direct@: Force the use of direct OpenGL rendering contexts (not all GLX---   implementations support direct rendering contexts). A fatal error is---   generated if direct rendering is not supported by the OpenGL---   implementation. If neither @-indirect@ or @-direct@ are used to force a---   particular behavior, GLUT will attempt to use direct rendering if---   possible and otherwise fallback to indirect rendering.------ * @-gldebug@: After processing callbacks and\/or events, call---   'Graphics.UI.GLUT.Debugging.reportErrors' to check if there are any pending---   OpenGL errors. Using this option is helpful in detecting OpenGL run-time---   errors.------ * @-sync@: Enable synchronous X protocol transactions. This option makes---   it easier to track down potential X protocol errors.--initialize :: String      -- ^ The program name.-           -> [String]    -- ^ The command line arguments-           -> IO [String] -- ^ Non-GLUT command line arguments-initialize prog args =-   with (1 + genericLength args) $ \argcBuf ->-   withMany withCString (prog : args) $ \argvPtrs ->-   withArray0 nullPtr argvPtrs $ \argvBuf -> do-   glutInit argcBuf argvBuf-   newArgc <- peek argcBuf-   newArgvPtrs <- peekArray (fromIntegral newArgc) argvBuf-   newArgv <- mapM peekCString newArgvPtrs-   return $ tail newArgv---- | Convenience action: Initialize GLUT, returning the program name and any--- non-GLUT command line arguments.--getArgsAndInitialize :: IO (String, [String])-getArgsAndInitialize = do-   prog <- getProgName-   args <- getArgs-   nonGLUTArgs <- initialize prog args-   return (prog, nonGLUTArgs)----------------------------------------------------------------------------------- | (/freeglut only/) De-initialize GLUT. After this, one has to use--- 'initialize' or 'getArgsAndInitialize' to initialize GLUT again.--exit :: IO ()-exit = glutExit-------------------------------------------------------------------------------------- | Controls the /initial window position/.  Windows created by--- 'Graphics.UI.GLUT.Window.createWindow' will be requested to be created with--- the current /initial window position/. The initial value of the /initial--- window position/ GLUT state is @'Position' (-1) (-1)@. If either the X or Y--- component of the /initial window position/ is negative, the actual window--- position is left to the window system to determine.------ The intent of the /initial window position/ is to provide a suggestion to--- the window system for a window\'s initial position. The window system is--- not obligated to use this information. Therefore, GLUT programs should not--- assume the window was created at the specified position.--initialWindowPosition :: StateVar Position-initialWindowPosition =-   makeStateVar getInitialWindowPosition setInitialWindowPosition--getInitialWindowPosition :: IO Position-getInitialWindowPosition = do-   x <- simpleGet fromIntegral glut_INIT_WINDOW_X-   y <- simpleGet fromIntegral glut_INIT_WINDOW_Y-   return $ Position x y--setInitialWindowPosition :: Position -> IO ()-setInitialWindowPosition (Position x y) =-    glutInitWindowPosition (fromIntegral x) (fromIntegral y)-------------------------------------------------------------------------------------- | Controls the /initial window size/.  Windows created by--- 'Graphics.UI.GLUT.Window.createWindow' will be requested to be created with--- the current /initial window size/. The initial value of the /initial window--- size/ GLUT state is @'Size' 300 300@. If either the width or the height--- component of the /initial window size/ is non-positive, the actual window--- size is left to the window system to determine.------ The intent of the /initial window size/ is to provide a suggestion to the--- window system for a window\'s initial size. The window system is not--- obligated to use this information. Therefore, GLUT programs should not--- assume the window was created at the specified size. A GLUT program should--- use the window\'s reshape callback to determine the true size of the--- window.--initialWindowSize :: StateVar Size-initialWindowSize = makeStateVar getInitialWindowSize setInitialWindowSize--getInitialWindowSize :: IO Size-getInitialWindowSize = do-   w <- simpleGet fromIntegral glut_INIT_WINDOW_WIDTH-   h <- simpleGet fromIntegral glut_INIT_WINDOW_HEIGHT-   return $ Size w h--setInitialWindowSize :: Size -> IO ()-setInitialWindowSize (Size w h) =-   glutInitWindowSize (fromIntegral w) (fromIntegral h)-------------------------------------------------------------------------------------- | A single aspect of a window which is to be created, used in conjunction--- with 'initialDisplayMode'.--data DisplayMode-   = RGBAMode-     -- ^ Select an RGBA mode window. This is the default if neither 'RGBAMode'-     -- nor 'IndexMode' are specified.-   | RGBMode-     -- ^ An alias for 'RGBAMode'.-   | IndexMode-     -- ^ Select a color index mode window. This overrides 'RGBAMode' if it is-     -- also specified.-   | LuminanceMode-     -- ^ Select a window with a \"luminance\" color model. This model provides-     -- the functionality of OpenGL\'s RGBA color model, but the green and blue-     -- components are not maintained in the frame buffer. Instead each pixel\'s-     -- red component is converted to an index between zero and-     --  'Graphics.UI.GLUT.Colormap.numColorMapEntries' and looked up in a-     -- per-window color map to determine the color of pixels within the window.-     -- The initial colormap of 'LuminanceMode' windows is initialized to be a-     -- linear gray ramp, but can be modified with GLUT\'s colormap actions.-     -- /Implementation Notes:/ 'LuminanceMode' is not supported on most OpenGL-     -- platforms.-   | WithAlphaComponent-     -- ^ Select a window with an alpha component to the color buffer(s).-   | WithAccumBuffer-     -- ^ Select a window with an accumulation buffer.-   | WithDepthBuffer-     -- ^ Select a window with a depth buffer.-   | WithStencilBuffer-     -- ^ Select a window with a stencil buffer.-   | WithAuxBuffers Int-     -- ^ (/freeglut only/) Select a window with /n/ (1 .. 4) auxiliary buffers.-     -- Any /n/ outside the range 1 .. 4 is a fatal error.-   | SingleBuffered-     -- ^ Select a single buffered window. This is the default if neither-     -- 'DoubleBuffered' nor 'SingleBuffered' are specified.-   | DoubleBuffered-     -- ^ Select a double buffered window. This overrides 'SingleBuffered' if it-     -- is also specified.-   | Multisampling-     -- ^ Select a window with multisampling support. If multisampling is not-     -- available, a non-multisampling window will automatically be chosen.-     -- Note: both the OpenGL client-side and server-side implementations must-     -- support the @GLX_SAMPLE_SGIS@ extension for multisampling to be-     -- available. Deprecated, use 'WithSamplesPerPixel'.-   | WithSamplesPerPixel Int-     -- ^ Select a window with multisampling, using the given samples per pixel.-   | Stereoscopic-     -- ^ Select a stereo window.-   | Captionless-     -- ^ Select a window without a caption (/freeglut only/).-   | Borderless-     -- ^ Select a window without any borders (/freeglut only/).-   | SRGBMode-     -- ^ Select an sRGB mode window (/freeglut only/).-   deriving ( Eq, Ord, Show )--marshalDisplayMode :: DisplayMode -> CUInt-marshalDisplayMode m = case m of-   RGBAMode -> glut_RGBA-   RGBMode -> glut_RGB-   IndexMode -> glut_INDEX-   LuminanceMode -> glut_LUMINANCE-   WithAlphaComponent -> glut_ALPHA-   WithAccumBuffer -> glut_ACCUM-   WithDepthBuffer -> glut_DEPTH-   WithStencilBuffer -> glut_STENCIL-   WithAuxBuffers 1 -> glut_AUX1-   WithAuxBuffers 2 -> glut_AUX2-   WithAuxBuffers 3 -> glut_AUX3-   WithAuxBuffers 4 -> glut_AUX4-   WithAuxBuffers n ->-      error ("marshalDisplayMode: illegal number of auxiliary buffers: " ++ show n)-   SingleBuffered -> glut_SINGLE-   DoubleBuffered -> glut_DOUBLE-   Multisampling -> glut_MULTISAMPLE-   WithSamplesPerPixel _ -> error ("marshalDisplayMode: this should not happen")-   Stereoscopic -> glut_STEREO-   Captionless -> glut_CAPTIONLESS-   Borderless -> glut_BORDERLESS-   SRGBMode -> glut_SRGB-------------------------------------------------------------------------------------- | Controls the /initial display mode/ used when creating top-level windows,--- subwindows, and overlays to determine the OpenGL display mode for the--- to-be-created window or overlay.------ Note that 'RGBAMode' selects the RGBA color model, but it does not request any--- bits of alpha (sometimes called an /alpha buffer/ or /destination alpha/)--- be allocated. To request alpha, specify 'WithAlphaComponent'. The same--- applies to 'LuminanceMode'.--initialDisplayMode :: StateVar [DisplayMode]-initialDisplayMode = makeStateVar getInitialDisplayMode setInitialDisplayMode--getInitialDisplayMode :: IO [DisplayMode]-getInitialDisplayMode = do-   mode <- simpleGet fromIntegral glut_INIT_DISPLAY_MODE-   let displayModes = i2dms (mode .&. complement glut_MULTISAMPLE)-   if mode .&. glut_MULTISAMPLE == 0-      then return displayModes-      else do-         n <- get samplesPerPixel-         return $ WithSamplesPerPixel n : displayModes--i2dms :: CUInt -> [DisplayMode]-i2dms bitfield | IndexMode `elem` modes || LuminanceMode `elem` modes = modes-               | otherwise = RGBAMode : modes-   where modes = i2dmsWithoutRGBA bitfield--i2dmsWithoutRGBA :: CUInt -> [DisplayMode]-i2dmsWithoutRGBA bitfield =-   [ c | c <- [ IndexMode, LuminanceMode, WithAlphaComponent,-                WithAccumBuffer, WithDepthBuffer, WithStencilBuffer,-                WithAuxBuffers 1, WithAuxBuffers 2, WithAuxBuffers 3,-                WithAuxBuffers 4, SingleBuffered, DoubleBuffered, Multisampling,-                Stereoscopic, Captionless, Borderless, SRGBMode ]-       , (bitfield .&. marshalDisplayMode c) /= 0 ]--setInitialDisplayMode :: [DisplayMode] -> IO ()-setInitialDisplayMode modes = do-   let (spps, transformedModes) = mapAccumR handleMultisampling [] modes-   mapM_ (samplesPerPixel $=) spps-   glutInitDisplayMode (toBitfield marshalDisplayMode transformedModes)--handleMultisampling :: [Int] -> DisplayMode -> ([Int], DisplayMode)-handleMultisampling spps (WithSamplesPerPixel spp) = (spp : spps, Multisampling)-handleMultisampling spps mode                      = (spps, mode)--toBitfield :: (Num b, Bits b) => (a -> b) -> [a] -> b-toBitfield marshal = foldl (.|.) 0 . map marshal---- | Contains 'True' if the /current display mode/ is supported, 'False'--- otherwise.--displayModePossible :: GettableStateVar Bool-displayModePossible =-   makeGettableStateVar $ simpleGet (/= 0) glut_DISPLAY_MODE_POSSIBLE------------------------------------------------------------------------------------samplesPerPixel :: StateVar Int-samplesPerPixel = makeStateVar getSamplesPerPixel setSamplesPerPixel--getSamplesPerPixel :: IO Int-getSamplesPerPixel = do-   m <- multisamplingSupported-   if m-      then simpleGet fromIntegral (fromIntegral glut_MULTISAMPLE)-      else return defaultSamplesPerPixels--defaultSamplesPerPixels :: Int-defaultSamplesPerPixels = 4--setSamplesPerPixel :: Int -> IO ()-setSamplesPerPixel spp = do-   m <- multisamplingSupported-   when m $-      glutSetOption (fromIntegral glut_MULTISAMPLE) (fromIntegral spp)--multisamplingSupported :: IO Bool-multisamplingSupported = isKnown "glutGetModeValues"-   where isKnown = fmap (/= nullFunPtr) . getAPIEntryInternal-------------------------------------------------------------------------------------- | Capabilities for 'initialDisplayCapabilities', most of them are extensions--- of the constructors of 'DisplayMode'.--data DisplayCapability-   = DisplayRGBA  -- ^ Number of bits of red, green, blue, and alpha in the RGBA-                  --   color buffer. Default is \"'IsAtLeast' @1@\" for red,-                  --   green, blue, and alpha capabilities, and \"'IsEqualTo'-                  --   @1@\" for the RGBA color model capability.-   | DisplayRGB   -- ^ Number of bits of red, green, and blue in the RGBA color-                  --   buffer and zero bits of alpha color buffer precision.-                  --   Default is \"'IsAtLeast' @1@\" for the red, green, and-                  --   blue capabilities, and \"'IsNotLessThan' @0@\" for alpha-                  --   capability, and \"'IsEqualTo' @1@\" for the RGBA color-                  --   model capability.-   | DisplayRed   -- ^ Red color buffer precision in bits. Default is-                  --   \"'IsAtLeast' @1@\".-   | DisplayGreen -- ^ Green color buffer precision in bits. Default is-                  --   \"'IsAtLeast' @1@\".-   | DisplayBlue  -- ^ Blue color buffer precision in bits. Default is-                  --   \"'IsAtLeast' @1@\".-   | DisplayIndex -- ^ Boolean if the color model is color index or not. True is-                  --   color index. Default is \"'IsAtLeast' @1@\".-   | DisplayBuffer -- ^ Number of bits in the color index color buffer. Default-                  --   is \"'IsAtLeast' @1@\".-   | DisplaySingle -- ^ Boolean indicate the color buffer is single buffered.-                  --   Default is \"'IsEqualTo' @1@\".-   | DisplayDouble -- ^ Boolean indicating if the color buffer is double-                  --   buffered. Default is \"'IsEqualTo' @1@\".-   | DisplayAccA  -- ^ Red, green, blue, and alpha accumulation buffer precision-                  --   in  bits. Default is \"'IsAtLeast' @1@\" for red, green,-                  --   blue, and alpha capabilities.-   | DisplayAcc   -- ^ Red, green, and green accumulation buffer precision in-                  --   bits and zero bits of alpha accumulation buffer precision.-                  --   Default is \"'IsAtLeast' @1@\" for red, green, and blue-                  --   capabilities, and \"'IsNotLessThan' @0@\" for the alpha-                  --   capability.-   | DisplayAlpha -- ^ Alpha color buffer precision in bits. Default is-                  --   \"'IsAtLeast' @1@\".-   | DisplayDepth -- ^ Number of bits of precsion in the depth buffer. Default-                  --   is \"'IsAtLeast' @12@\".-   | DisplayStencil -- ^ Number of bits in the stencil buffer. Default is-                  --   \"'IsNotLessThan' @1@\".-   | DisplaySamples -- ^ Indicates the number of multisamples to use based on-                  --   GLX\'s @SGIS_multisample@ extension (for antialiasing).-                  --   Default is \"'IsNotGreaterThan' @4@\". This default means-                  --   that a GLUT application can request multisampling if-                  --   available by simply specifying \"'With' 'DisplaySamples'\".-   | DisplayStereo -- ^ Boolean indicating the color buffer is supports-                  --   OpenGL-style stereo. Default is \"'IsEqualTo' @1@\".-   | DisplayLuminance -- ^ Number of bits of red in the RGBA and zero bits of green,-                  --   blue (alpha not specified) of color buffer precision.-                  --   Default is \"'IsAtLeast' @1@\" for the red capabilitis,-                  --   and \"'IsEqualTo' @0@\" for the green and blue-                  --   capabilities, and \"'IsEqualTo' @1@\" for the RGBA color-                  --   model capability, and, for X11, \"'IsEqualTo' @1@\" for-                  --   the 'DisplayXStaticGray' capability. SGI InfiniteReality (and-                  --   other future machines) support a 16-bit luminance (single-                  --   channel) display mode (an additional 16-bit alpha channel-                  --   can also be requested). The red channel maps to gray-                  --   scale and green and blue channels are not available. A-                  --   16-bit precision luminance display mode is often-                  --   appropriate for medical imaging applications. Do not-                  --   expect many machines to support extended precision-                  --   luminance display modes.-   | DisplayAux   -- ^ (/freeglut only/) Number of auxiliary buffers. Default is-                  --   \"'IsEqualTo' @1@\".-   | DisplayNum   -- ^ A special capability name indicating where the value-                  --   represents the Nth frame buffer configuration matching-                  --   the description string. When not specified,-                  --   'initialDisplayCapabilities' also uses the first-                  --   (best matching) configuration. 'Num' requires a relation-                  --   and numeric value.-   | DisplayConformant -- ^ Boolean indicating if the frame buffer configuration is-                  --   conformant or not. Conformance information is based on-                  --   GLX\'s @EXT_visual_rating@ extension if supported. If the-                  --   extension is not supported, all visuals are assumed-                  --   conformant. Default is \"'IsEqualTo' @1@\".-   | DisplaySlow  -- ^ Boolean indicating if the frame buffer configuration is-                  --   slow or not. Slowness information is based on GLX\'s-                  --   @EXT_visual_rating@ extension if supported. If the-                  --   extension is not supported, all visuals are assumed fast.-                  --   Note that slowness is a relative designation relative to-                  --   other frame buffer configurations available. The intent-                  --   of the slow capability is to help programs avoid frame-                  --   buffer configurations that are slower (but perhaps higher-                  --   precision) for the current machine. Default is-                  --   \"'IsAtLeast' @0@\". This default means that slow visuals-                  --   are used in preference to fast visuals, but fast visuals-                  --   will still be allowed.-   | DisplayWin32PFD -- ^ Only recognized on GLUT implementations for Win32, this-                  --   capability name matches the Win32 Pixel Format Descriptor-                  --   by number. 'DisplayWin32PFD' can only be used with 'Where'.-   | DisplayXVisual -- ^ Only recongized on GLUT implementations for the X Window-                  --   System, this capability name matches the X visual ID by-                  --   number. 'DisplayXVisual' requires a relation and numeric value.-   | DisplayXStaticGray -- ^ Only recongized on GLUT implementations for the X Window-                  --   System, boolean indicating if the frame buffer-                  --   configuration\'s X visual is of type @StaticGray@.-                  --   Default is \"'IsEqualTo' @1@\".-   | DisplayXGrayScale -- ^ Only recongized on GLUT implementations for the X Window-                  --   System, boolean indicating if the frame buffer-                  --   configuration\'s X visual is of type @GrayScale@. Default-                  --   is \"'IsEqualTo' @1@\".-   | DisplayXStaticColor -- ^ Only recongized on GLUT implementations for the X Window-                  --   System, boolean indicating if the frame buffer-                  --   configuration\'s X visual is of type @StaticColor@.-                  --   Default is \"'IsEqualTo' @1@\".-   | DisplayXPseudoColor -- ^ Only recongized on GLUT implementations for the X Window-                  --   System, boolean indicating if the frame buffer-                  --   configuration\'s X visual is of type @PsuedoColor@.-                  --   Default is \"'IsEqualTo' @1@\".-   | DisplayXTrueColor -- ^ Only recongized on GLUT implementations for the X Window-                  --   System, boolean indicating if the frame buffer-                  --   configuration\'s X visual is of type @TrueColor@. Default-                  --   is \"'IsEqualTo' @1@\".-   | DisplayXDirectColor -- ^ Only recongized on GLUT implementations for the X Window-                  --   System, boolean indicating if the frame buffer-                  --   configuration\'s X visual is of type @DirectColor@.-                  --   Default is \"'IsEqualTo' @1@\".-   deriving ( Eq, Ord, Show )--displayCapabilityToString :: DisplayCapability -> String-displayCapabilityToString x = case x of-   DisplayRGBA         -> "rgba"-   DisplayRGB          -> "rgb"-   DisplayRed          -> "red"-   DisplayGreen        -> "green"-   DisplayBlue         -> "blue"-   DisplayIndex        -> "index"-   DisplayBuffer       -> "buffer"-   DisplaySingle       -> "single"-   DisplayDouble       -> "double"-   DisplayAccA         -> "acca"-   DisplayAcc          -> "acc"-   DisplayAlpha        -> "alpha"-   DisplayDepth        -> "depth"-   DisplayStencil      -> "stencil"-   DisplaySamples      -> "samples"-   DisplayStereo       -> "stereo"-   DisplayLuminance    -> "luminance"-   DisplayAux          -> "aux"-   DisplayNum          -> "num"-   DisplayConformant   -> "conformant"-   DisplaySlow         -> "slow"-   DisplayWin32PFD     -> "win32pfd"-   DisplayXVisual      -> "xvisual"-   DisplayXStaticGray  -> "xstaticgray"-   DisplayXGrayScale   -> "xgrayscale"-   DisplayXStaticColor -> "xstaticcolor"-   DisplayXPseudoColor -> "xpseudocolor"-   DisplayXTrueColor   -> "xtruecolor"-   DisplayXDirectColor -> "xdirectcolor"---- | A single capability description for 'initialDisplayCapabilities'.--data DisplayCapabilityDescription-   = Where DisplayCapability Relation Int-     -- ^ A description of a capability with a specific relation to a numeric-     --   value.-   | With  DisplayCapability-     -- ^ When the relation and numeric value are not specified, each capability-     --   has a different default, see the different constructors of-     --   'DisplayCapability'.-   deriving ( Eq, Ord, Show )--displayCapabilityDescriptionToString ::  DisplayCapabilityDescription -> String-displayCapabilityDescriptionToString (Where c r i) =-   displayCapabilityToString c ++ relationToString r ++ show i-displayCapabilityDescriptionToString (With c) = displayCapabilityToString c---- | Controls the /initial display mode/ used when creating top-level windows,--- subwindows, and overlays to determine the OpenGL display mode for the--- to-be-created window or overlay. It is described by a list of zero or more--- capability descriptions, which are translated into a set of criteria used to--- select the appropriate frame buffer configuration. The criteria are matched--- in strict left to right order of precdence. That is, the first specified--- criterion (leftmost) takes precedence over the later criteria for non-exact--- criteria ('IsGreaterThan', 'IsLessThan', etc.). Exact criteria ('IsEqualTo',--- 'IsNotEqualTo') must match exactly so precedence is not relevant.------ Unspecified capability descriptions will result in unspecified criteria being--- generated. These unspecified criteria help 'initialDisplayCapabilities'--- behave sensibly with terse display mode descriptions.------ Here is an example using 'initialDisplayCapabilities':------ @---    initialDisplayCapabilities $= [ With  DisplayRGB,---                                    Where DisplayDepth IsAtLeast 16,---                                    With  DisplaySamples,---                                    Where DisplayStencil IsNotLessThan 2,---                                    With  DisplayDouble ]--- @------ The above call requests a window with an RGBA color model (but requesting--- no bits of alpha), a depth buffer with at least 16 bits of precision but--- preferring more, multisampling if available, at least 2 bits of stencil--- (favoring less stencil to more as long as 2 bits are available), and double--- buffering.--initialDisplayCapabilities :: SettableStateVar [DisplayCapabilityDescription]-initialDisplayCapabilities =-   makeSettableStateVar $ \caps ->-      withCString-         (concat . intersperse " " . map displayCapabilityDescriptionToString $-          caps)-         glutInitDisplayString----------------------------------------------------------------------------------- | How rendering context for new windows are created.--data RenderingContext-   = -- | Create a new context via @glXCreateContext@ or @wglCreateContext@-     --   (default).-     CreateNewContext-   | -- | Re-use the current rendering context.-     UseCurrentContext-   deriving ( Eq, Ord, Show )--marshalRenderingContext :: RenderingContext -> CInt-marshalRenderingContext CreateNewContext  = glut_CREATE_NEW_CONTEXT-marshalRenderingContext UseCurrentContext = glut_USE_CURRENT_CONTEXT--unmarshalRenderingContext :: CInt -> RenderingContext-unmarshalRenderingContext r-   | r == glut_CREATE_NEW_CONTEXT  = CreateNewContext-   | r == glut_USE_CURRENT_CONTEXT = UseCurrentContext-   | otherwise = error "unmarshalRenderingContext"----------------------------------------------------------------------------------- | (/freeglut only/) Controls the creation of rendering contexts for new--- windows.--renderingContext :: StateVar RenderingContext-renderingContext =-   makeStateVar-      (simpleGet unmarshalRenderingContext glut_RENDERING_CONTEXT)-      (glutSetOption glut_RENDERING_CONTEXT . marshalRenderingContext)----------------------------------------------------------------------------------- | The kind of GLX rendering context used. Direct rendering provides a--- performance advantage in some implementations. However, direct rendering--- contexts cannot be shared outside a single process, and they may be unable--- to render to GLX pixmaps.--data DirectRendering-   = -- | Rendering is always done through the X server. This corresponds to-     -- the command line argument @-indirect@, see 'initialize'.-     ForceIndirectContext-   | -- | Try to use direct rendering, silently using indirect rendering if this-     -- is not possible.-     AllowDirectContext-   | -- | Try to use direct rendering, issue a warning and use indirect-     -- rendering if this is not possible.-     TryDirectContext-   | -- | Try to use direct rendering, issue an error and terminate the program-     -- if this is not possible.This corresponds to the command line argument-     -- @-direct@, see 'initialize'.-     ForceDirectContext-   deriving ( Eq, Ord, Show )--marshalDirectRendering :: DirectRendering -> CInt-marshalDirectRendering x = case x of-   ForceIndirectContext -> glut_FORCE_INDIRECT_CONTEXT-   AllowDirectContext -> glut_ALLOW_DIRECT_CONTEXT-   TryDirectContext -> glut_TRY_DIRECT_CONTEXT-   ForceDirectContext -> glut_FORCE_DIRECT_CONTEXT--unmarshalDirectRendering :: CInt -> DirectRendering-unmarshalDirectRendering x-   | x == glut_FORCE_INDIRECT_CONTEXT = ForceIndirectContext-   | x == glut_ALLOW_DIRECT_CONTEXT = AllowDirectContext-   | x == glut_TRY_DIRECT_CONTEXT = TryDirectContext-   | x == glut_FORCE_DIRECT_CONTEXT = ForceDirectContext-   | otherwise = error ("unmarshalDirectRendering: illegal value " ++ show x)----------------------------------------------------------------------------------- | (/freeglut on X11 only/) Controls which kind of rendering context is--- created when a new one is required.--directRendering :: StateVar DirectRendering-directRendering =-   makeStateVar-      (simpleGet unmarshalDirectRendering glut_DIRECT_RENDERING)-      (glutSetOption glut_DIRECT_RENDERING . marshalDirectRendering)----------------------------------------------------------------------------------- | (/freeglut only/) Controls the API major\/minor version of the OpenGL--- context. If a version less than or equal to 2.1 is requested, the context--- returned may implement any version no less than that requested and no--- greater than 2.1. If version 3.0 is requested, the context returned must--- implement exactly version 3.0. Versioning behavior once GL versions beyond--- 3.0 are defined will be defined by an amendment to the OpenGL specification--- to define dependencies on such GL versions.------ 'Graphics.Rendering.OpenGL.GL.StringQueries.glVersion' and--- 'Graphics.Rendering.OpenGL.GL.StringQueries.majorMinor' will return the--- actual version supported by a context.------ The default context version is (1, 0), which will typically return an--- OpenGL 2.1 context, if one is available.--initialContextVersion :: StateVar (Int, Int)-initialContextVersion = makeStateVar getContextVersion setContextVersion--getContextVersion :: IO (Int, Int)-getContextVersion = do-   major <- simpleGet fromIntegral glut_INIT_MAJOR_VERSION-   minor <- simpleGet fromIntegral glut_INIT_MINOR_VERSION-   return (major, minor)--setContextVersion :: (Int, Int) -> IO ()-setContextVersion (major, minor) =-   glutInitContextVersion (fromIntegral major) (fromIntegral minor)----------------------------------------------------------------------------------- | A flag affecting the rendering context to create, used in conjunction--- with 'initialContextFlags'.--data ContextFlag-   = -- | Debug contexts are intended for use during application development,-     -- and provide additional runtime checking, validation, and logging-     -- functionality while possibly incurring performance penalties. The-     -- additional functionality provided by debug contexts may vary according-     -- to the implementation. In some cases a debug context may be identical-     -- to a non-debug context.-     DebugContext-   | -- | Forward-compatible contexts are defined only for OpenGL versions 3.0-     -- and later. They must not support functionality marked as /deprecated/-     -- by that version of the API, while a non-forward-compatible context must-     -- support all functionality in that version, deprecated or not.-     ForwardCompatibleContext-   deriving ( Eq, Ord, Show )--marshalContextFlag :: ContextFlag -> CInt-marshalContextFlag x = case x of-   DebugContext -> glut_DEBUG-   ForwardCompatibleContext -> glut_FORWARD_COMPATIBLE----------------------------------------------------------------------------------- | (/freeglut only/) Controls the set of flags for the rendering context.--initialContextFlags :: StateVar [ContextFlag]-initialContextFlags = makeStateVar getContextFlags setContextFlags--getContextFlags :: IO [ContextFlag]-getContextFlags = simpleGet i2cfs glut_INIT_FLAGS--i2cfs :: CInt -> [ContextFlag]-i2cfs bitfield =-   [ c | c <- [ DebugContext, ForwardCompatibleContext ]-       , (fromIntegral bitfield .&. marshalContextFlag c) /= 0 ]--setContextFlags :: [ContextFlag] -> IO ()-setContextFlags = glutInitContextFlags . toBitfield marshalContextFlag------------------------------------------------------------------------------------ | An OpenGL API profile, affecting the rendering context to create, used--- in conjunction with 'initialContextProfile'.--data ContextProfile-   = -- | The OpenGL /core/ profile, which all OpenGL 3.2 implementations-     -- are required to support.-      CoreProfile-   | -- | The OpenGL /compatibility/ profile, which is optional for OpenGL-     -- 3.2 implementations.-     CompatibilityProfile-   deriving ( Eq, Ord, Show )--marshalContextProfile :: ContextProfile -> CInt-marshalContextProfile x = case x of-   CoreProfile -> glut_CORE_PROFILE-   CompatibilityProfile -> glut_COMPATIBILITY_PROFILE----------------------------------------------------------------------------------- | (/freeglut only/) Controls the set of profiles for the rendering context.--initialContextProfile :: StateVar [ContextProfile]-initialContextProfile = makeStateVar getContextProfiles setContextProfiles--getContextProfiles :: IO [ContextProfile]-getContextProfiles = simpleGet i2cps glut_INIT_PROFILE--i2cps :: CInt -> [ContextProfile]-i2cps bitfield =-   [ c | c <- [ CoreProfile, CompatibilityProfile ]-       , (fromIntegral bitfield .&. marshalContextProfile c) /= 0 ]--setContextProfiles :: [ContextProfile] -> IO ()-setContextProfiles = glutInitContextProfile . toBitfield marshalContextProfile
− Graphics/UI/GLUT/Menu.hs 
@@ -1,262 +0,0 @@-{-# OPTIONS_GHC -fno-cse #-}------------------------------------------------------------------------------------- |--- Module      :  Graphics.UI.GLUT.Menu--- Copyright   :  (c) Sven Panne 2002-2013--- License     :  BSD3------ Maintainer  :  Sven Panne <svenpanne@gmail.com>--- Stability   :  stable--- Portability :  portable------ GLUT supports simple cascading pop-up menus. They are designed to let a user--- select various modes within a program. The functionality is simple and--- minimalistic and is meant to be that way. Do not mistake GLUT\'s pop-up menu--- facility with an attempt to create a full-featured user interface.--------------------------------------------------------------------------------------module Graphics.UI.GLUT.Menu (-   Menu(..), MenuItem(..), MenuCallback, attachMenu,-   numMenuItems-) where--import Data.Array-import Data.IORef-import qualified Data.Map as Map-import Control.Monad-import Data.Map ( Map )-import Foreign.C.String-import Foreign.C.Types-import Foreign.Ptr-import Graphics.Rendering.OpenGL-import Graphics.UI.GLUT.Callbacks.Registration-import Graphics.UI.GLUT.QueryUtils-import Graphics.UI.GLUT.Raw-import Graphics.UI.GLUT.Types-------------------------------------------------------------------------------------- | A menu is simply a list of menu items, possibly with an associated font.-data Menu-   = Menu [MenuItem]-   | MenuWithFont BitmapFont [MenuItem]--menuFont :: Menu -> Maybe BitmapFont-menuFont (Menu _) = Nothing-menuFont (MenuWithFont font _) = Just font--menuItems :: Menu -> [MenuItem]-menuItems (Menu items) = items-menuItems (MenuWithFont _ items) = items---- | A single item within a menu can either be a plain menu entry or a sub-menu--- entry, allowing for arbitrarily deep nested menus.-data MenuItem-   = MenuEntry String MenuCallback -- ^ A plain menu entry with an associated-                                   --   callback, which is triggered when the-                                   --   user selects the entry-   | SubMenu   String Menu         -- ^ A sub-menu, which is cascaded when the-                                   --   user selects the entry, allowing-                                   --   sub-menu entries to be selected--type MenuCallback = IO ()---- | Create a new pop-up menu for the /current window,/ attaching it to the--- given mouse button. A previously attached menu (if any), is detached before--- and won\'t receive callbacks anymore.------ It is illegal to call 'attachMenu' while any (sub-)menu is in use, i.e.--- popped up.------ /X Implementation Notes:/ If available, GLUT for X will take advantage of--- overlay planes for implementing pop-up menus. The use of overlay planes can--- eliminate display callbacks when pop-up menus are deactivated. The--- @SERVER_OVERLAY_VISUALS@ convention is used to determine if overlay visuals--- are available.--attachMenu :: MouseButton -> Menu -> IO ()-attachMenu mouseButton menu = do-   win <- getCurrentWindow "attachMenu"-   let hook = MenuHook win mouseButton-   detachMenu hook-   unless (null (menuItems menu)) $ do-      (_, destructor) <- traverseMenu menu-      addToMenuTable hook destructor-      attachMenu_ mouseButton--detachMenu :: MenuHook -> IO ()-detachMenu hook@(MenuHook _ mouseButton) = do-   maybeDestructor <- lookupInMenuTable hook-   case maybeDestructor of-      Nothing         -> return ()-      Just destructor -> do detachMenu_ mouseButton-                            destructor-   deleteFromMenuTable hook--traverseMenu :: Menu -> IO (MenuID, Destructor)-traverseMenu menu = do-   let items = menuItems menu-       callbackArray = listArray (1, length items) (map makeCallback items)-   cb <- makeMenuFunc (\i -> callbackArray ! (fromIntegral i))-   menuID <- glutCreateMenu cb-   maybe (return ()) (setMenuFont menuID) (menuFont menu)-   destructors <- zipWithM addMenuItem items [1..]-   let destructor = do sequence_ destructors-                       glutDestroyMenu menuID-                       freeHaskellFunPtr cb-   return (menuID, destructor)--makeCallback :: MenuItem -> MenuCallback-makeCallback (MenuEntry _ cb) = cb-makeCallback _ = error "shouldn't receive a callback for submenus"--addMenuItem :: MenuItem -> Value -> IO Destructor-addMenuItem (MenuEntry s _) v = do-   addMenuEntry s v-   return $ glutRemoveMenuItem 1-addMenuItem (SubMenu s m) _ = do-   (menuID, destructor) <- saveExcursion (traverseMenu m)-   addSubMenu s menuID-   return $ do glutRemoveMenuItem 1-               destructor---- Perform an action, saving/restoring the current menu around it-saveExcursion :: IO a -> IO a-saveExcursion act = do-   menuID <- get currentMenu-   returnValue <- act-   when (isRealMenu menuID) $-      currentMenu $= menuID-   return returnValue------------------------------------------------------------------------------------- This seems to be a common Haskell hack nowadays: A plain old global variable--- with an associated mutator. Perhaps some language/library support is needed?--{-# NOINLINE theMenuTable #-}-theMenuTable :: IORef MenuTable-theMenuTable = unsafePerformIO (newIORef emptyMenuTable)--getMenuTable :: IO MenuTable-getMenuTable = readIORef theMenuTable--modifyMenuTable :: (MenuTable -> MenuTable) -> IO ()-modifyMenuTable = modifyIORef theMenuTable------------------------------------------------------------------------------------- To facilitate cleanup, we have to keep track how to destroy menus which are--- currently attached in a window to a mouse button.--data MenuHook = MenuHook Window MouseButton-   deriving ( Eq, Ord )--type Destructor = IO ()--type MenuTable = Map MenuHook Destructor--emptyMenuTable :: MenuTable-emptyMenuTable = Map.empty--lookupInMenuTable :: MenuHook -> IO (Maybe Destructor)-lookupInMenuTable callbackID =-   fmap (Map.lookup callbackID) getMenuTable--deleteFromMenuTable :: MenuHook -> IO ()-deleteFromMenuTable callbackID =-   modifyMenuTable (Map.delete callbackID)--addToMenuTable :: MenuHook -> Destructor -> IO ()-addToMenuTable callbackID funPtr =-   modifyMenuTable (Map.insert callbackID funPtr)------------------------------------------------------------------------------------type MenuID = CInt-type Value  = CInt-------------------------------------------------------------------------------------- | Controls the /current menu./ If no menus exist or the previous /current--- menu/ was destroyed, a pseudo menu is returned.--currentMenu :: StateVar MenuID-currentMenu = makeStateVar glutGetMenu glutSetMenu---- | Returns 'True' if the given menu identifier refers to a real menu, not--- a pseudo one.--isRealMenu :: MenuID -> Bool-isRealMenu = (/= 0)-------------------------------------------------------------------------------------- | Add a menu entry to the bottom of the /current menu./ The given string will--- be displayed for the newly added menu entry. If the menu entry is selected by--- the user, the menu\'s callback will be called passing the given value as the--- callback\'s parameter.--addMenuEntry :: String -> Value -> IO ()-addMenuEntry name value = withCString name $ \n -> glutAddMenuEntry n value---- | Add a sub-menu trigger to the bottom of the /current menu./ The given--- string will be displayed for the newly added sub-menu trigger. If the--- sub-menu trigger is entered, the sub-menu specified by the given menu--- identifier will be cascaded, allowing sub-menu menu items to be selected.--addSubMenu :: String -> MenuID -> IO ()-addSubMenu name menuID = withCString name $ \n -> glutAddSubMenu n menuID------------------------------------------------------------------------------------{- UNUSED--- | Change the specified menu entry in the /current menu/ into a menu entry.--- The given position determines which menu item should be changed and must be--- between 1 (the topmost menu item) and--- 'Graphics.UI.GLUT.State.getNumMenuItems' inclusive. The menu item to change--- does not have to be a menu entry already. The given string will be displayed--- for the newly changed menu entry. The given value will be returned to the--- menu\'s callback if this menu entry is selected.--foreign import CALLCONV unsafe "glutChangeToMenuEntry" glutChangeToMenuEntry ::-   Item -> CString -> Value -> IO ()---- | Change the specified menu item in the /current menu/ into a sub-menu--- trigger. The  given position determines which menu item should be changed and--- must be between 1 and 'Graphics.UI.GLUT.State.getNumMenuItems' inclusive. The--- menu item to change does not have to be a sub-menu trigger already. The--- given name will be displayed for the newly changed sub-menu trigger. The--- given menu identifier names the sub-menu to cascade from the newly added--- sub-menu trigger.--foreign import CALLCONV unsafe "glutChangeToSubMenu" glutChangeToSubMenu ::-   Item -> CString -> MenuID -> IO ()--}-------------------------------------------------------------------------------------- | Attach a mouse button for the /current window/ to the identifier of the--- /current menu./ By attaching a menu identifier to a button, the named menu--- will be popped up when the user presses the specified button. Note that the--- menu is attached to the button by identifier, not by reference.--attachMenu_ :: MouseButton -> IO ()-attachMenu_ = glutAttachMenu . marshalMouseButton---- | Detach an attached mouse button from the /current window./--detachMenu_ :: MouseButton -> IO ()-detachMenu_ = glutDetachMenu . marshalMouseButton-------------------------------------------------------------------------------------- | Contains the number of menu items in the /current menu./--numMenuItems :: GettableStateVar Int-numMenuItems = makeGettableStateVar $ simpleGet fromIntegral glut_MENU_NUM_ITEMS------------------------------------------------------------------------------------setMenuFont :: MenuID -> BitmapFont -> IO ()-setMenuFont menuID font = glutSetMenuFont menuID =<< marshalBitmapFont font
− Graphics/UI/GLUT/Objects.hs 
@@ -1,180 +0,0 @@------------------------------------------------------------------------------------ |--- Module      :  Graphics.UI.GLUT.Objects--- Copyright   :  (c) Sven Panne 2002-2013--- License     :  BSD3------ Maintainer  :  Sven Panne <svenpanne@gmail.com>--- Stability   :  stable--- Portability :  portable------ GLUT includes a number of routines for generating easily recognizable 3D--- geometric objects. These routines reflect functionality available in the--- @aux@ toolkit described in the /OpenGL Programmer\'s Guide/ and are included--- in GLUT to allow the construction of simple GLUT programs that render--- recognizable objects. These routines can be implemented as pure OpenGL--- rendering routines. The routines do not generate display lists for the--- objects they create. The routines generate normals appropriate for lighting--- but do not generate texture coordinates (except for the solid teapot, teacup--- and teaspoon). If VBOs should be used instead of the fixed function pipeline,--- specify at least one of the attribute locations--- 'Graphics.UI.GLUT.State.vertexAttribCoord3' or--- 'Graphics.UI.GLUT.State.vertexAttribNormal'.--------------------------------------------------------------------------------------module Graphics.UI.GLUT.Objects (-   -- * Rendering flavour-   Flavour(..),--   -- * Object description-   Object(..),--   -- * Type synonyms-   Sides, Rings, NumLevels,--   -- * Rendering-   renderObject-) where--import Foreign.C.Types-import Foreign.Marshal.Utils-import Foreign.Ptr-import Graphics.Rendering.OpenGL-import Graphics.UI.GLUT.Raw-------------------------------------------------------------------------------------- | Flavour of object rendering--data Flavour-   = -- | Object is rendered as a solid with shading and surface normals.-     Solid-   | -- | Object is rendered as a wireframe without surface normals.-     Wireframe-   deriving ( Eq, Ord, Show )-------------------------------------------------------------------------------------- | GLUT offers five types of objects:------ *  The five Platonic solids, see---    <http://mathworld.wolfram.com/PlatonicSolid.html>.------ * A rhombic dodecahedron, see---   <http://mathworld.wolfram.com/RhombicDodecahedron.html>.------ * Approximations to rounded objects.------ * The classic teaset modeled by Martin Newell in 1975. Both surface normals---   and texture coordinates for the teaset are generated.------ * A Sierpinski sponge, see---   <http://mathworld.wolfram.com/Tetrix.html>.--data Object-   = -- | A cube centered at the modeling coordinates origin with sides of the-     --   given length.-     Cube Height-   | -- | A dodecahedron (12-sided regular solid) centered at the modeling-     --   coordinates origin with a radius of @sqrt 3@.-     Dodecahedron-   | -- | A icosahedron (20-sided regular solid) centered at the modeling-     --   coordinates origin with a radius of 1.0.-     Icosahedron-   | -- | Render a solid octahedron (8-sided regular solid) centered at the-     --   modeling coordinates origin with a radius of 1.0.-     Octahedron-   | -- | Render a solid tetrahedron (4-sided regular solid) centered at the-     --   modeling coordinates origin with a radius of @sqrt 3@.-     Tetrahedron-   | -- | (/freeglut only/) A rhombic dodecahedron whose corners are at most a-     -- distance of one from the origin. The rhombic dodecahedron has faces-     -- which are identical rhombi, but which have some vertices at which three-     -- faces meet and some vertices at which four faces meet. The length of-     -- each side is @(sqrt 3)\/2@. Vertices at which four faces meet are found-     -- at @(0, 0, +\/-1)@ and @(+\/-(sqrt 2)\/2, +\/-(sqrt 2)\/2, 0)@.-     RhombicDodecahedron-   | -- | A sphere centered at the modeling coordinates origin of the specified-     --   radius. The sphere is subdivided around the Z axis into slices-     --   (similar to lines of longitude) and along the Z axis into stacks-     --   (similar to lines of latitude).-     Sphere' Radius Slices Stacks-   | -- | A cone oriented along the Z axis. The base of the cone is placed at Z-     --   = 0, and the top at Z = the given height. The cone is subdivided-     --   around the Z axis into slices, and along the Z axis into stacks.-     Cone Radius Height Slices Stacks-   | -- |(/freeglut only/) A cylinder oriented along the Z axis. The base of the-     --  cylinder is placed at Z = 0, and the top at Z = the given height. The-     --  cylinder is subdivided around the Z axis into slices, and along the Z-     -- axis into stacks.-     Cylinder' Radius Height Slices Stacks-   | -- | A torus (doughnut) centered at the modeling coordinates origin-     -- whose axis is aligned with the Z axis. The torus is described by its-     -- inner and outer radius, the number of sides for each radial section,-     -- and the number of radial divisions (rings).-     Torus Radius Radius Sides Rings-   | -- | A teapot with a given relative size.-     Teapot Height-   | -- |(/freeglut only/) A teacup with a given relative size.-     Teacup Height-   | -- |(/freeglut only/) A teaspoon with a given relative size.-     Teaspoon Height-   | -- |(/freeglut only/) A Sierpinski sponge of a given level, where a level-     -- 0 sponge is the same as a 'Tetrahedron'.-     SierpinskiSponge NumLevels-   deriving ( Eq, Ord, Show )------------------------------------------------------------------------------------type Sides     = GLint-type Rings     = GLint-type NumLevels = GLint-------------------------------------------------------------------------------------- | Render an object in the given flavour.--renderObject :: Flavour -> Object -> IO ()-renderObject Solid     (Cube h)             = glutSolidCube h-renderObject Wireframe (Cube h)             = glutWireCube  h-renderObject Solid     Dodecahedron         = glutSolidDodecahedron-renderObject Wireframe Dodecahedron         = glutWireDodecahedron-renderObject Solid     Icosahedron          = glutSolidIcosahedron-renderObject Wireframe Icosahedron          = glutWireIcosahedron-renderObject Solid     Octahedron           = glutSolidOctahedron-renderObject Wireframe Octahedron           = glutWireOctahedron-renderObject Solid     Tetrahedron          = glutSolidTetrahedron-renderObject Wireframe Tetrahedron          = glutWireTetrahedron-renderObject Solid     RhombicDodecahedron  = glutSolidRhombicDodecahedron-renderObject Wireframe RhombicDodecahedron  = glutWireRhombicDodecahedron-renderObject Solid     (Sphere' r s t)      = glutSolidSphere r s t-renderObject Wireframe (Sphere' r s t)      = glutWireSphere  r s t-renderObject Solid     (Cone r h s t)       = glutSolidCone r h s t-renderObject Wireframe (Cone r h s t)       = glutWireCone  r h s t-renderObject Solid     (Cylinder' r h s t)  = glutSolidCylinder r h s t-renderObject Wireframe (Cylinder' r h s t)  = glutWireCylinder r h s t-renderObject Solid     (Torus i o s r)      = glutSolidTorus i o s r-renderObject Wireframe (Torus i o s r)      = glutWireTorus  i o s r-renderObject Solid     (Teapot h)           = glutSolidTeapot h-renderObject Wireframe (Teapot h)           = glutWireTeapot  h-renderObject Solid     (Teacup h)           = glutSolidTeacup h-renderObject Wireframe (Teacup h)           = glutWireTeacup  h-renderObject Solid     (Teaspoon h)         = glutSolidTeaspoon h-renderObject Wireframe (Teaspoon h)         = glutWireTeaspoon  h-renderObject Solid     (SierpinskiSponge n) = solidSierpinskiSponge n-renderObject Wireframe (SierpinskiSponge n) = wireSierpinskiSponge n------------------------------------------------------------------------------------solidSierpinskiSponge :: NumLevels -> IO ()-solidSierpinskiSponge = sierpinskiSponge glutSolidSierpinskiSponge--wireSierpinskiSponge :: NumLevels -> IO ()-wireSierpinskiSponge = sierpinskiSponge glutWireSierpinskiSponge---- for consistency, we hide the offset and scale on the Haskell side-sierpinskiSponge :: (CInt -> Ptr GLdouble -> Height -> IO ()) -> NumLevels -> IO ()-sierpinskiSponge f n =-   with (Vertex3 0 0 0) $ \offsetBuf ->-      f (fromIntegral n) ((castPtr :: Ptr (Vertex3 GLdouble) -> Ptr GLdouble) offsetBuf) 1
− Graphics/UI/GLUT/Overlay.hs 
@@ -1,168 +0,0 @@------------------------------------------------------------------------------------ |--- Module      :  Graphics.UI.GLUT.Overlay--- Copyright   :  (c) Sven Panne 2002-2013--- License     :  BSD3------ Maintainer  :  Sven Panne <svenpanne@gmail.com>--- Stability   :  stable--- Portability :  portable------ When  overlay hardware is available, GLUT provides a set of routines for--- establishing, using, and removing an overlay for GLUT windows. When an--- overlay is established, a separate OpenGL context is also established. A--- window\'s overlay OpenGL state is kept distinct from the normal planes\'--- OpenGL state.--------------------------------------------------------------------------------------module Graphics.UI.GLUT.Overlay (-   -- * Overlay creation and destruction-   hasOverlay, overlayPossible,--   -- * Showing and hiding an overlay-   overlayVisible,--   -- * Changing the /layer in use/-   Layer(..), layerInUse,--   -- * Re-displaying-   postOverlayRedisplay-) where--import Graphics.Rendering.OpenGL ( GLenum, StateVar, makeStateVar-                                 , GettableStateVar, makeGettableStateVar-                                 , SettableStateVar, makeSettableStateVar )-import Graphics.UI.GLUT.QueryUtils-import Graphics.UI.GLUT.Raw-import Graphics.UI.GLUT.Types-------------------------------------------------------------------------------------- | Controls the overlay for the /current window/. The requested display mode--- for the overlay is determined by the /initial display mode/.--- 'overlayPossible' can be used to determine if an overlay is possible for the--- /current window/ with the current /initial display mode/. Do not attempt to--- establish an overlay when one is not possible; GLUT will terminate the--- program.------ When 'hasOverlay' is set to 'True' when an overlay already exists, the--- existing overlay is first removed, and then a new overlay is established. The--- state of the old overlay\'s OpenGL context is discarded. Implicitly, the--- window\'s /layer in use/ changes to the overlay immediately after the overlay--- is established.------ The initial display state of an overlay is shown, however the overlay is only--- actually shown if the overlay\'s window is shown.------ Setting 'hasOverlay' to 'False' is safe even if no overlay is currently--- established, nothing happens in this case. Implicitly, the window\'s /layer--- in use/ changes to the normal plane immediately once the overlay is removed.------ If the program intends to re-establish the overlay later, it is typically--- faster and less resource intensive to use 'overlayVisible' to simply change--- the display status of the overlay.------ /X Implementation Notes:/ GLUT for X uses the @SERVER_OVERLAY_VISUALS@--- convention to determine if overlay visuals are available. While the--- convention allows for opaque overlays (no transparency) and overlays with the--- transparency specified as a bitmask, GLUT overlay management only provides--- access to transparent pixel overlays.------ Until RGBA overlays are better understood, GLUT only supports color index--- overlays.--hasOverlay :: StateVar Bool-hasOverlay = makeStateVar getHasOverlay setHasOverlay--setHasOverlay :: Bool -> IO ()-setHasOverlay False = glutRemoveOverlay-setHasOverlay True  = glutEstablishOverlay--getHasOverlay :: IO Bool-getHasOverlay = layerGet (/= 0) glut_HAS_OVERLAY-------------------------------------------------------------------------------------- | Contains 'True' if an overlay could be established for the /current window/--- given the current /initial display mode/. If it contains 'False', setting--- 'hasOverlay' will fail with a fatal error.--overlayPossible :: GettableStateVar Bool-overlayPossible = makeGettableStateVar $ layerGet (/= 0) glut_OVERLAY_POSSIBLE-------------------------------------------------------------------------------------- | Controls the visibility of the overlay of the /current window/.------ The effect of showing or hiding an overlay takes place immediately. Note that--- setting 'overlayVisible' to 'True' will not actually display the overlay--- unless the window is also shown (and even a shown window may be obscured by--- other windows, thereby obscuring the overlay). It is typically faster and--- less resource intensive to use the routines below to control the display--- status of an overlay as opposed to removing and re-establishing the overlay.--overlayVisible :: SettableStateVar Bool-overlayVisible =-   makeSettableStateVar $ \flag ->-      if flag then glutShowOverlay else glutHideOverlay-------------------------------------------------------------------------------------- | The /layer in use/.-data Layer-   = Normal   -- ^ The normal plane.-   | Overlay  -- ^ The overlay.-   deriving ( Eq, Ord, Show )--marshalLayer :: Layer -> GLenum-marshalLayer x = case x of-   Normal -> glut_NORMAL-   Overlay -> glut_OVERLAY--unmarshalLayer :: GLenum -> Layer-unmarshalLayer x-   | x == glut_NORMAL  = Normal-   | x == glut_OVERLAY = Overlay-   | otherwise = error ("unmarshalLayer: illegal value " ++ show x)-------------------------------------------------------------------------------------- | Controls the per-window /layer in use/ for the /current window/, which can--- either be the normal plane or the overlay. Selecting the overlay should only--- be done if an overlay exists, however windows without an overlay may still--- set the /layer in use/ to 'Normal'. OpenGL commands for the window are--- directed to the current /layer in use/.--layerInUse :: StateVar Layer-layerInUse =-   makeStateVar getLayerInUse setLayerInUse--setLayerInUse :: Layer -> IO ()-setLayerInUse = glutUseLayer . marshalLayer--getLayerInUse :: IO Layer-getLayerInUse = layerGet (unmarshalLayer . fromIntegral) glut_LAYER_IN_USE-------------------------------------------------------------------------------------- | Mark the overlay of the given window (or the /current window/, if none is--- supplied) as needing to be redisplayed. The next iteration through--- 'Graphics.UI.GLUT.Begin.mainLoop', the window\'s overlay display callback--- (or simply the display callback if no overlay display callback is registered)--- will be called to redisplay the window\'s overlay plane. Multiple calls to--- 'postOverlayRedisplay' before the next display callback opportunity (or--- overlay display callback opportunity if one is registered) generate only a--- single redisplay. 'postOverlayRedisplay' may be called within a window\'s--- display or overlay display callback to re-mark that window for redisplay.------ Logically, overlay damage notification for a window is treated as a--- 'postOverlayRedisplay' on the damaged window. Unlike damage reported by the--- window system, 'postOverlayRedisplay' will not set to true the overlay\'s--- damaged status (see 'Graphics.UI.GLUT.State.damaged').------ Also, see 'Graphics.UI.GLUT.Window.postRedisplay'.--postOverlayRedisplay :: Maybe Window -> IO ()-postOverlayRedisplay =-   maybe glutPostOverlayRedisplay (\(Window win) -> glutPostWindowOverlayRedisplay win)
− Graphics/UI/GLUT/QueryUtils.hs 
@@ -1,35 +0,0 @@-{-# OPTIONS_HADDOCK hide #-}------------------------------------------------------------------------------------ |--- Module      :  Graphics.UI.GLUT.QueryUtils--- Copyright   :  (c) Sven Panne 2002-2013--- License     :  BSD3------ Maintainer  :  Sven Panne <svenpanne@gmail.com>--- Stability   :  stable--- Portability :  portable------ This is a purely internal module with utilities to query GLUT state.--------------------------------------------------------------------------------------module Graphics.UI.GLUT.QueryUtils (-  Getter, simpleGet, layerGet, deviceGet-) where--import Foreign.C.Types-import Graphics.Rendering.OpenGL ( GLenum )-import Graphics.UI.GLUT.Raw------------------------------------------------------------------------------------type PrimGetter =                GLenum -> IO CInt-type Getter a   = (CInt -> a) -> GLenum -> IO a--makeGetter :: PrimGetter -> Getter a-makeGetter g f = fmap f . g--simpleGet, layerGet, deviceGet :: Getter a-simpleGet = makeGetter glutGet-layerGet  = makeGetter glutLayerGet-deviceGet = makeGetter glutDeviceGet
− Graphics/UI/GLUT/Raw.hs 
@@ -1,28 +0,0 @@-{-# OPTIONS_HADDOCK hide #-}--------------------------------------------------------------------------------- |--- Module      :  Graphics.UI.GLUT.Raw--- Copyright   :  (c) Sven Panne 2013--- License     :  BSD3------ Maintainer  :  Sven Panne <svenpanne@gmail.com>--- Stability   :  stable--- Portability :  portable------ A convenience module, combining all raw GLUT modules.-----------------------------------------------------------------------------------module Graphics.UI.GLUT.Raw (-   module Graphics.UI.GLUT.Raw.APIEntry,-   module Graphics.UI.GLUT.Raw.Callbacks,-   module Graphics.UI.GLUT.Raw.Fonts,-   module Graphics.UI.GLUT.Raw.Functions,-   module Graphics.UI.GLUT.Raw.Tokens-) where--import Graphics.UI.GLUT.Raw.APIEntry-import Graphics.UI.GLUT.Raw.Callbacks-import Graphics.UI.GLUT.Raw.Fonts-import Graphics.UI.GLUT.Raw.Functions-import Graphics.UI.GLUT.Raw.Tokens
− Graphics/UI/GLUT/Raw/APIEntry.hs 
@@ -1,51 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface, CPP #-}-{-# OPTIONS_HADDOCK hide #-}------------------------------------------------------------------------------------ |--- Module      :  Graphics.UI.GLUT.Raw.APIEntry--- Copyright   :  (c) Sven Panne 2002-2013--- License     :  BSD3------ Maintainer  :  Sven Panne <svenpanne@gmail.com>--- Stability   :  stable--- Portability :  portable------ This is a purely internal module for handling an OpenGL-like extension--- mechanism for GLUT.--------------------------------------------------------------------------------------module Graphics.UI.GLUT.Raw.APIEntry (-   Invoker, getAPIEntry, getAPIEntryInternal,-   FunPtr, unsafePerformIO-) where--import Foreign.C.String-import Foreign.Marshal.Error-import Foreign.Ptr-import System.IO.Unsafe--#ifdef __HUGS__-{-# CFILES cbits/HsGLUT.c #-}-#endif------------------------------------------------------------------------------------type Invoker a = FunPtr a -> a---- | Retrieve a GLUT API entry by name. Throws a userError when no entry with--- the given name was found.-getAPIEntry :: String -> IO (FunPtr a)-getAPIEntry extensionEntry =-   throwIfNullFunPtr ("unknown GLUT entry " ++ extensionEntry) $-      getAPIEntryInternal extensionEntry--throwIfNullFunPtr :: String -> IO (FunPtr a) -> IO (FunPtr a)-throwIfNullFunPtr = throwIf (== nullFunPtr) . const--getAPIEntryInternal :: String -> IO (FunPtr a)-getAPIEntryInternal extensionEntry =-   withCString extensionEntry hs_GLUT_getProcAddress--foreign import ccall unsafe "hs_GLUT_getProcAddress"-   hs_GLUT_getProcAddress :: CString -> IO (FunPtr a)
− Graphics/UI/GLUT/Raw/Callbacks.hs 
@@ -1,243 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}-{-# OPTIONS_HADDOCK hide #-}--------------------------------------------------------------------------------- |--- Module      :  Graphics.UI.GLUT.Raw.Callbacks--- Copyright   :  (c) Sven Panne 2013--- License     :  BSD3------ Maintainer  :  Sven Panne <svenpanne@gmail.com>--- Stability   :  stable--- Portability :  portable------ All GLUT callbacks.-----------------------------------------------------------------------------------module Graphics.UI.GLUT.Raw.Callbacks (-   AppStatusFunc, makeAppStatusFunc,-   ButtonBoxFunc, makeButtonBoxFunc,-   CloseFunc, makeCloseFunc,-   DialsFunc, makeDialsFunc,-   DisplayFunc, makeDisplayFunc,-   EntryFunc, makeEntryFunc,-   IdleFunc, makeIdleFunc,-   InitContextFunc, makeInitContextFunc,-   JoystickFunc, makeJoystickFunc,-   KeyboardFunc, makeKeyboardFunc,-   KeyboardUpFunc, makeKeyboardUpFunc,-   MenuDestroyFunc, makeMenuDestroyFunc,-   MenuFunc, makeMenuFunc,-   MenuStateFunc, makeMenuStateFunc,-   MenuStatusFunc, makeMenuStatusFunc,-   MotionFunc, makeMotionFunc,-   MouseFunc, makeMouseFunc,-   MouseWheelFunc, makeMouseWheelFunc,-   MultiButtonFunc, makeMultiButtonFunc,-   MultiEntryFunc, makeMultiEntryFunc,-   MultiMotionFunc, makeMultiMotionFunc,-   MultiPassiveFunc, makeMultiPassiveFunc,-   OverlayDisplayFunc, makeOverlayDisplayFunc,-   PassiveMotionFunc, makePassiveMotionFunc,-   PositionFunc, makePositionFunc,-   ReshapeFunc, makeReshapeFunc,-   SpaceballButtonFunc, makeSpaceballButtonFunc,-   SpaceballMotionFunc, makeSpaceballMotionFunc,-   SpaceballRotateFunc, makeSpaceballRotateFunc,-   SpecialFunc, makeSpecialFunc,-   SpecialUpFunc, makeSpecialUpFunc,-   TabletButtonFunc, makeTabletButtonFunc,-   TabletMotionFunc, makeTabletMotionFunc,-   TimerFunc, makeTimerFunc,-   VisibilityFunc, makeVisibilityFunc,-   WMCloseFunc, makeWMCloseFunc,-   WindowStatusFunc, makeWindowStatusFunc-) where--import Foreign.C.Types-import Foreign.Ptr--type AppStatusFunc = CInt -> IO ()--foreign import ccall "wrapper"-   makeAppStatusFunc :: AppStatusFunc -> IO (FunPtr AppStatusFunc)--type ButtonBoxFunc = CInt -> CInt -> IO ()--foreign import ccall "wrapper"-   makeButtonBoxFunc :: ButtonBoxFunc -> IO (FunPtr ButtonBoxFunc)--type CloseFunc = IO ()--foreign import ccall "wrapper"-   makeCloseFunc :: CloseFunc -> IO (FunPtr CloseFunc)--type DialsFunc = CInt -> CInt -> IO ()--foreign import ccall "wrapper"-   makeDialsFunc :: DialsFunc -> IO (FunPtr DialsFunc)--type DisplayFunc = IO ()--foreign import ccall "wrapper"-   makeDisplayFunc :: DisplayFunc -> IO (FunPtr DisplayFunc)--type EntryFunc = CInt -> IO ()--foreign import ccall "wrapper"-   makeEntryFunc :: EntryFunc -> IO (FunPtr EntryFunc)--type IdleFunc = IO ()--foreign import ccall "wrapper"-   makeIdleFunc :: IdleFunc -> IO (FunPtr IdleFunc)--type InitContextFunc = IO ()--foreign import ccall "wrapper"-   makeInitContextFunc :: InitContextFunc -> IO (FunPtr InitContextFunc)--type JoystickFunc = CUInt -> CInt -> CInt -> CInt -> IO ()--foreign import ccall "wrapper"-   makeJoystickFunc :: JoystickFunc -> IO (FunPtr JoystickFunc)--type KeyboardFunc = CUChar -> CInt -> CInt -> IO ()--foreign import ccall "wrapper"-   makeKeyboardFunc :: KeyboardFunc -> IO (FunPtr KeyboardFunc)--type KeyboardUpFunc = CUChar -> CInt -> CInt -> IO ()--foreign import ccall "wrapper"-   makeKeyboardUpFunc :: KeyboardUpFunc -> IO (FunPtr KeyboardUpFunc)--type MenuDestroyFunc = IO ()--foreign import ccall "wrapper"-   makeMenuDestroyFunc :: MenuDestroyFunc -> IO (FunPtr MenuDestroyFunc)--type MenuFunc = CInt -> IO ()--foreign import ccall "wrapper"-   makeMenuFunc :: MenuFunc -> IO (FunPtr MenuFunc)--type MenuStateFunc = CInt -> IO ()--foreign import ccall "wrapper"-   makeMenuStateFunc :: MenuStateFunc -> IO (FunPtr MenuStateFunc)--type MenuStatusFunc = CInt -> CInt -> CInt -> IO ()--foreign import ccall "wrapper"-   makeMenuStatusFunc :: MenuStatusFunc -> IO (FunPtr MenuStatusFunc)--type MotionFunc = CInt -> CInt -> IO ()--foreign import ccall "wrapper"-   makeMotionFunc :: MotionFunc -> IO (FunPtr MotionFunc)--type MouseFunc = CInt -> CInt -> CInt -> CInt -> IO ()--foreign import ccall "wrapper"-   makeMouseFunc :: MouseFunc -> IO (FunPtr MouseFunc)--type MouseWheelFunc = CInt -> CInt -> CInt -> CInt -> IO ()--foreign import ccall "wrapper"-   makeMouseWheelFunc :: MouseWheelFunc -> IO (FunPtr MouseWheelFunc)--type MultiButtonFunc = CInt -> CInt -> CInt -> CInt -> CInt -> IO ()--foreign import ccall "wrapper"-   makeMultiButtonFunc :: MultiButtonFunc -> IO (FunPtr MultiButtonFunc)--type MultiEntryFunc = CInt -> CInt -> IO ()--foreign import ccall "wrapper"-   makeMultiEntryFunc :: MultiEntryFunc -> IO (FunPtr MultiEntryFunc)--type MultiMotionFunc = CInt -> CInt -> CInt -> IO ()--foreign import ccall "wrapper"-   makeMultiMotionFunc :: MultiMotionFunc -> IO (FunPtr MultiMotionFunc)--type MultiPassiveFunc = CInt -> CInt -> CInt -> IO ()--foreign import ccall "wrapper"-   makeMultiPassiveFunc :: MultiPassiveFunc -> IO (FunPtr MultiPassiveFunc)--type OverlayDisplayFunc = IO ()--foreign import ccall "wrapper"-   makeOverlayDisplayFunc :: OverlayDisplayFunc -> IO (FunPtr OverlayDisplayFunc)--type PassiveMotionFunc = CInt -> CInt -> IO ()--foreign import ccall "wrapper"-   makePassiveMotionFunc :: PassiveMotionFunc -> IO (FunPtr PassiveMotionFunc)--type PositionFunc = CInt -> CInt -> IO ()--foreign import ccall "wrapper"-   makePositionFunc :: PositionFunc -> IO (FunPtr PositionFunc)--type ReshapeFunc = CInt -> CInt -> IO ()--foreign import ccall "wrapper"-   makeReshapeFunc :: ReshapeFunc -> IO (FunPtr ReshapeFunc)--type SpaceballButtonFunc = CInt -> CInt -> IO ()--foreign import ccall "wrapper"-   makeSpaceballButtonFunc :: SpaceballButtonFunc -> IO (FunPtr SpaceballButtonFunc)--type SpaceballMotionFunc = CInt -> CInt -> CInt -> IO ()--foreign import ccall "wrapper"-   makeSpaceballMotionFunc :: SpaceballMotionFunc -> IO (FunPtr SpaceballMotionFunc)--type SpaceballRotateFunc = CInt -> CInt -> CInt -> IO ()--foreign import ccall "wrapper"-   makeSpaceballRotateFunc :: SpaceballRotateFunc -> IO (FunPtr SpaceballRotateFunc)--type SpecialFunc = CInt -> CInt -> CInt -> IO ()--foreign import ccall "wrapper"-   makeSpecialFunc :: SpecialFunc -> IO (FunPtr SpecialFunc)--type SpecialUpFunc = CInt -> CInt -> CInt -> IO ()--foreign import ccall "wrapper"-   makeSpecialUpFunc :: SpecialUpFunc -> IO (FunPtr SpecialUpFunc)--type TabletButtonFunc = CInt -> CInt -> CInt -> CInt -> IO ()--foreign import ccall "wrapper"-   makeTabletButtonFunc :: TabletButtonFunc -> IO (FunPtr TabletButtonFunc)--type TabletMotionFunc = CInt -> CInt -> IO ()--foreign import ccall "wrapper"-   makeTabletMotionFunc :: TabletMotionFunc -> IO (FunPtr TabletMotionFunc)--type TimerFunc = CInt -> IO ()--foreign import ccall "wrapper"-   makeTimerFunc :: TimerFunc -> IO (FunPtr TimerFunc)--type VisibilityFunc = CInt -> IO ()--foreign import ccall "wrapper"-   makeVisibilityFunc :: VisibilityFunc -> IO (FunPtr VisibilityFunc)--type WMCloseFunc = IO ()--foreign import ccall "wrapper"-   makeWMCloseFunc :: WMCloseFunc -> IO (FunPtr WMCloseFunc)--type WindowStatusFunc = CInt -> IO ()--foreign import ccall "wrapper"-   makeWindowStatusFunc :: WindowStatusFunc -> IO (FunPtr WindowStatusFunc)
− Graphics/UI/GLUT/Raw/Fonts.hs 
@@ -1,93 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}-{-# OPTIONS_HADDOCK hide #-}--------------------------------------------------------------------------------- |--- Module      :  Graphics.UI.GLUT.Raw.Fonts--- Copyright   :  (c) Sven Panne 2013--- License     :  BSD3------ Maintainer  :  Sven Panne <svenpanne@gmail.com>--- Stability   :  stable--- Portability :  portable------ Our own functions to access font identifiers in a portable way.-----------------------------------------------------------------------------------module Graphics.UI.GLUT.Raw.Fonts (-   BitmapFont(..), GLUTbitmapFont, marshalBitmapFont,-   StrokeFont(..), GLUTstrokeFont, marshalStrokeFont-) where--import Foreign.C.Types-import Foreign.Ptr-------------------------------------------------------------------------------------- | The bitmap fonts available in GLUT. The exact bitmap to be used is--- defined by the standard X glyph bitmaps for the X font with the given name.--data BitmapFont-   = Fixed8By13   -- ^ A fixed width font with every character fitting in an 8-                  --   by 13 pixel rectangle.-                  --   (@-misc-fixed-medium-r-normal--13-120-75-75-C-80-iso8859-1@)-   | Fixed9By15   -- ^ A fixed width font with every character fitting in an 9-                  --   by 15 pixel rectangle.-                  --   (@-misc-fixed-medium-r-normal--15-140-75-75-C-90-iso8859-1@)-   | TimesRoman10 -- ^ A 10-point proportional spaced Times Roman font.-                  --   (@-adobe-times-medium-r-normal--10-100-75-75-p-54-iso8859-1@)-   | TimesRoman24 -- ^ A 24-point proportional spaced Times Roman font.-                  --   (@-adobe-times-medium-r-normal--24-240-75-75-p-124-iso8859-1@)-   | Helvetica10  -- ^ A 10-point proportional spaced Helvetica font.-                  --   (@-adobe-helvetica-medium-r-normal--10-100-75-75-p-56-iso8859-1@)-   | Helvetica12  -- ^ A 12-point proportional spaced Helvetica font.-                  --   (@-adobe-helvetica-medium-r-normal--12-120-75-75-p-67-iso8859-1@)-   | Helvetica18  -- ^ A 18-point proportional spaced Helvetica font.-                  --   (@-adobe-helvetica-medium-r-normal--18-180-75-75-p-98-iso8859-1@)-   deriving ( Eq, Ord, Show )---- Alas, fonts in GLUT are not denoted by some integral value, but by opaque--- pointers on the C side. Even worse: For WinDoze, they are simply small ints,--- casted to void*, for other platforms addresses of global variables are used.--- And all is done via ugly #ifdef-ed #defines... Aaaaargl! So the only portable--- way is using integers on the Haskell side and doing the marshaling via some--- small C wrappers around those macros. *sigh*-type GLUTbitmapFont = Ptr ()--marshalBitmapFont :: BitmapFont -> IO GLUTbitmapFont-marshalBitmapFont x = case x of-   Fixed8By13 -> hs_GLUT_marshalBitmapFont 0-   Fixed9By15 -> hs_GLUT_marshalBitmapFont 1-   TimesRoman10 -> hs_GLUT_marshalBitmapFont 2-   TimesRoman24 -> hs_GLUT_marshalBitmapFont 3-   Helvetica10 -> hs_GLUT_marshalBitmapFont 4-   Helvetica12 -> hs_GLUT_marshalBitmapFont 5-   Helvetica18 -> hs_GLUT_marshalBitmapFont 6---foreign import ccall unsafe "hs_GLUT_marshalBitmapFont"-   hs_GLUT_marshalBitmapFont :: CInt -> IO (Ptr a)-------------------------------------------------------------------------------------- | The stroke fonts available in GLUT.-data StrokeFont-   = Roman     -- ^ A proportionally spaced Roman Simplex font for ASCII-               --   characters 32 through 127. The maximum top character in the-               --   font is 119.05 units; the bottom descends 33.33 units.-   | MonoRoman -- ^ A mono-spaced spaced Roman Simplex font (same characters as-               --   'Roman') for ASCII characters 32 through 127. The maximum-               --   top character in the font is 119.05 units; the bottom-               --   descends 33.33 units. Each character is 104.76 units wide.-   deriving ( Eq, Ord, Show )---- Same remarks as for GLUTbitmapFont-type GLUTstrokeFont = Ptr ()--marshalStrokeFont :: StrokeFont -> IO GLUTstrokeFont-marshalStrokeFont x = case x of-   Roman -> hs_GLUT_marshalStrokeFont 0-   MonoRoman -> hs_GLUT_marshalStrokeFont 1--foreign import ccall unsafe "hs_GLUT_marshalStrokeFont"-   hs_GLUT_marshalStrokeFont :: CInt -> IO (Ptr a)
− Graphics/UI/GLUT/Raw/Functions.hs 
@@ -1,343 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface, CPP #-}-{-# OPTIONS_HADDOCK hide #-}--------------------------------------------------------------------------------- |--- Module      :  Graphics.UI.GLUT.Raw.Functions--- Copyright   :  (c) Sven Panne 2013--- License     :  BSD3------ Maintainer  :  Sven Panne <svenpanne@gmail.com>--- Stability   :  stable--- Portability :  portable------ All raw functions from GLUT and freeglut.-----------------------------------------------------------------------------------module Graphics.UI.GLUT.Raw.Functions (-   glutAddMenuEntry,-   glutAddSubMenu,-   glutAppStatusFunc,-   glutAttachMenu,-   glutBitmapCharacter,-   glutBitmapHeight,-   glutBitmapLength,-   glutBitmapString,-   glutBitmapWidth,-   glutButtonBoxFunc,-   glutChangeToMenuEntry,-   glutChangeToSubMenu,-   glutCloseFunc,-   glutCopyColormap,-   glutCreateMenu,-   glutCreateSubWindow,-   glutCreateWindow,-   glutDestroyMenu,-   glutDestroyWindow,-   glutDetachMenu,-   glutDeviceGet,-   glutDialsFunc,-   glutDisplayFunc,-   glutEnterGameMode,-   glutEntryFunc,-   glutEstablishOverlay,-   glutExit,-   glutExtensionSupported,-   glutForceJoystickFunc,-   glutFullScreen,-   glutFullScreenToggle,-   glutGameModeGet,-   glutGameModeString,-   glutGet,-   glutGetColor,-   glutGetMenu,-   glutGetMenuData,-   glutGetModeValues,-   glutGetModifiers,-   glutGetProcAddress,-   glutGetWindow,-   glutGetWindowData,-   glutHideOverlay,-   glutHideWindow,-   glutIconifyWindow,-   glutIdleFunc,-   glutIgnoreKeyRepeat,-   glutInit,-   glutInitContextFlags,-   glutInitContextFunc,-   glutInitContextProfile,-   glutInitContextVersion,-   glutInitDisplayMode,-   glutInitDisplayString,-   glutInitWindowPosition,-   glutInitWindowSize,-   glutJoystickFunc,-   glutKeyboardFunc,-   glutKeyboardUpFunc,-   glutLayerGet,-   glutLeaveFullScreen,-   glutLeaveGameMode,-   glutLeaveMainLoop,-   glutMainLoop,-   glutMainLoopEvent,-   glutMenuDestroyFunc,-   glutMenuStateFunc,-   glutMenuStatusFunc,-   glutMotionFunc,-   glutMouseFunc,-   glutMouseWheelFunc,-   glutMultiButtonFunc,-   glutMultiEntryFunc,-   glutMultiMotionFunc,-   glutMultiPassiveFunc,-   glutOverlayDisplayFunc,-   glutPassiveMotionFunc,-   glutPopWindow,-   glutPositionFunc,-   glutPositionWindow,-   glutPostOverlayRedisplay,-   glutPostRedisplay,-   glutPostWindowOverlayRedisplay,-   glutPostWindowRedisplay,-   glutPushWindow,-   glutRemoveMenuItem,-   glutRemoveOverlay,-   glutReportErrors,-   glutReshapeFunc,-   glutReshapeWindow,-   glutSetColor,-   glutSetCursor,-   glutSetIconTitle,-   glutSetKeyRepeat,-   glutSetMenu,-   glutSetMenuData,-   glutSetMenuFont,-   glutSetOption,-   glutSetVertexAttribCoord3,-   glutSetVertexAttribNormal,-   glutSetVertexAttribTexCoord2,-   glutSetWindow,-   glutSetWindowData,-   glutSetWindowTitle,-   glutSetupVideoResizing,-   glutShowOverlay,-   glutShowWindow,-   glutSolidCone,-   glutSolidCube,-   glutSolidCylinder,-   glutSolidDodecahedron,-   glutSolidIcosahedron,-   glutSolidOctahedron,-   glutSolidRhombicDodecahedron,-   glutSolidSierpinskiSponge,-   glutSolidSphere,-   glutSolidTeacup,-   glutSolidTeapot,-   glutSolidTeaspoon,-   glutSolidTetrahedron,-   glutSolidTorus,-   glutSpaceballButtonFunc,-   glutSpaceballMotionFunc,-   glutSpaceballRotateFunc,-   glutSpecialFunc,-   glutSpecialUpFunc,-   glutStopVideoResizing,-   glutStrokeCharacter,-   glutStrokeHeight,-   glutStrokeLength,-   glutStrokeString,-   glutStrokeWidth,-   glutSwapBuffers,-   glutTabletButtonFunc,-   glutTabletMotionFunc,-   glutTimerFunc,-   glutUseLayer,-   glutVideoPan,-   glutVideoResize,-   glutVideoResizeGet,-   glutVisibilityFunc,-   glutWMCloseFunc,-   glutWarpPointer,-   glutWindowStatusFunc,-   glutWireCone,-   glutWireCube,-   glutWireCylinder,-   glutWireDodecahedron,-   glutWireIcosahedron,-   glutWireOctahedron,-   glutWireRhombicDodecahedron,-   glutWireSierpinskiSponge,-   glutWireSphere,-   glutWireTeacup,-   glutWireTeapot,-   glutWireTeaspoon,-   glutWireTetrahedron,-   glutWireTorus-) where--import Foreign.C.Types-import Foreign.Ptr-import Graphics.Rendering.OpenGL.Raw.Core31.Types-import Graphics.UI.GLUT.Raw.APIEntry-import Graphics.UI.GLUT.Raw.Callbacks--#include "HsGLUTExt.h"--API_ENTRY(dyn_glutAddMenuEntry,ptr_glutAddMenuEntry,"glutAddMenuEntry",glutAddMenuEntry,Ptr CChar -> CInt -> IO ())-API_ENTRY(dyn_glutAddSubMenu,ptr_glutAddSubMenu,"glutAddSubMenu",glutAddSubMenu,Ptr CChar -> CInt -> IO ())-API_ENTRY(dyn_glutAppStatusFunc,ptr_glutAppStatusFunc,"glutAppStatusFunc",glutAppStatusFunc,FunPtr AppStatusFunc -> IO ())-API_ENTRY(dyn_glutAttachMenu,ptr_glutAttachMenu,"glutAttachMenu",glutAttachMenu,CInt -> IO ())-API_ENTRY(dyn_glutBitmapCharacter,ptr_glutBitmapCharacter,"glutBitmapCharacter",glutBitmapCharacter,Ptr a -> CInt -> IO ())-API_ENTRY(dyn_glutBitmapHeight,ptr_glutBitmapHeight,"glutBitmapHeight",glutBitmapHeight,Ptr a -> IO CInt)-API_ENTRY(dyn_glutBitmapLength,ptr_glutBitmapLength,"glutBitmapLength",glutBitmapLength,Ptr a -> Ptr CUChar -> IO CInt)-API_ENTRY(dyn_glutBitmapString,ptr_glutBitmapString,"glutBitmapString",glutBitmapString,Ptr a -> Ptr CUChar -> IO ())-API_ENTRY(dyn_glutBitmapWidth,ptr_glutBitmapWidth,"glutBitmapWidth",glutBitmapWidth,Ptr a -> CInt -> IO CInt)-API_ENTRY(dyn_glutButtonBoxFunc,ptr_glutButtonBoxFunc,"glutButtonBoxFunc",glutButtonBoxFunc,FunPtr ButtonBoxFunc -> IO ())-API_ENTRY(dyn_glutChangeToMenuEntry,ptr_glutChangeToMenuEntry,"glutChangeToMenuEntry",glutChangeToMenuEntry,CInt -> Ptr CChar -> CInt -> IO ())-API_ENTRY(dyn_glutChangeToSubMenu,ptr_glutChangeToSubMenu,"glutChangeToSubMenu",glutChangeToSubMenu,CInt -> Ptr CChar -> CInt -> IO ())-API_ENTRY(dyn_glutCloseFunc,ptr_glutCloseFunc,"glutCloseFunc",glutCloseFunc,FunPtr CloseFunc -> IO ())-API_ENTRY(dyn_glutCopyColormap,ptr_glutCopyColormap,"glutCopyColormap",glutCopyColormap,CInt -> IO ())-API_ENTRY(dyn_glutCreateMenu,ptr_glutCreateMenu,"glutCreateMenu",glutCreateMenu,FunPtr MenuFunc -> IO CInt)-API_ENTRY(dyn_glutCreateSubWindow,ptr_glutCreateSubWindow,"glutCreateSubWindow",glutCreateSubWindow,CInt -> CInt -> CInt -> CInt -> CInt -> IO CInt)-API_ENTRY(dyn_glutCreateWindow,ptr_glutCreateWindow,"glutCreateWindow",glutCreateWindow,Ptr CChar -> IO CInt)-API_ENTRY(dyn_glutDestroyMenu,ptr_glutDestroyMenu,"glutDestroyMenu",glutDestroyMenu,CInt -> IO ())-API_ENTRY(dyn_glutDestroyWindow,ptr_glutDestroyWindow,"glutDestroyWindow",glutDestroyWindow,CInt -> IO ())-API_ENTRY(dyn_glutDetachMenu,ptr_glutDetachMenu,"glutDetachMenu",glutDetachMenu,CInt -> IO ())-API_ENTRY(dyn_glutDeviceGet,ptr_glutDeviceGet,"glutDeviceGet",glutDeviceGet,GLenum -> IO CInt)-API_ENTRY(dyn_glutDialsFunc,ptr_glutDialsFunc,"glutDialsFunc",glutDialsFunc,FunPtr DialsFunc -> IO ())-API_ENTRY(dyn_glutDisplayFunc,ptr_glutDisplayFunc,"glutDisplayFunc",glutDisplayFunc,FunPtr DisplayFunc -> IO ())-API_ENTRY(dyn_glutEnterGameMode,ptr_glutEnterGameMode,"glutEnterGameMode",glutEnterGameMode,IO CInt)-API_ENTRY(dyn_glutEntryFunc,ptr_glutEntryFunc,"glutEntryFunc",glutEntryFunc,FunPtr EntryFunc -> IO ())-API_ENTRY_SAFE(dyn_glutEstablishOverlay,ptr_glutEstablishOverlay,"glutEstablishOverlay",glutEstablishOverlay,IO ())-API_ENTRY(dyn_glutExit,ptr_glutExit,"glutExit",glutExit,IO ())-API_ENTRY(dyn_glutExtensionSupported,ptr_glutExtensionSupported,"glutExtensionSupported",glutExtensionSupported,Ptr CChar -> IO CInt)-API_ENTRY(dyn_glutForceJoystickFunc,ptr_glutForceJoystickFunc,"glutForceJoystickFunc",glutForceJoystickFunc,IO ())-API_ENTRY(dyn_glutFullScreen,ptr_glutFullScreen,"glutFullScreen",glutFullScreen,IO ())-API_ENTRY(dyn_glutFullScreenToggle,ptr_glutFullScreenToggle,"glutFullScreenToggle",glutFullScreenToggle,IO ())-API_ENTRY(dyn_glutGameModeGet,ptr_glutGameModeGet,"glutGameModeGet",glutGameModeGet,GLenum -> IO CInt)-API_ENTRY(dyn_glutGameModeString,ptr_glutGameModeString,"glutGameModeString",glutGameModeString,Ptr CChar -> IO ())-API_ENTRY(dyn_glutGet,ptr_glutGet,"glutGet",glutGet,GLenum -> IO CInt)-API_ENTRY(dyn_glutGetColor,ptr_glutGetColor,"glutGetColor",glutGetColor,CInt -> CInt -> IO GLfloat)-API_ENTRY(dyn_glutGetMenu,ptr_glutGetMenu,"glutGetMenu",glutGetMenu,IO CInt)-API_ENTRY(dyn_glutGetMenuData,ptr_glutGetMenuData,"glutGetMenuData",glutGetMenuData,IO (Ptr a))-API_ENTRY(dyn_glutGetModeValues,ptr_glutGetModeValues,"glutGetModeValues",glutGetModeValues,GLenum -> Ptr CInt -> IO (Ptr CInt))-API_ENTRY(dyn_glutGetModifiers,ptr_glutGetModifiers,"glutGetModifiers",glutGetModifiers,IO CInt)-API_ENTRY(dyn_glutGetProcAddress,ptr_glutGetProcAddress,"glutGetProcAddress",glutGetProcAddress,Ptr CChar -> IO (FunPtr a))-API_ENTRY(dyn_glutGetWindow,ptr_glutGetWindow,"glutGetWindow",glutGetWindow,IO CInt)-API_ENTRY(dyn_glutGetWindowData,ptr_glutGetWindowData,"glutGetWindowData",glutGetWindowData,IO (Ptr a))-API_ENTRY_SAFE(dyn_glutHideOverlay,ptr_glutHideOverlay,"glutHideOverlay",glutHideOverlay,IO ())-API_ENTRY(dyn_glutHideWindow,ptr_glutHideWindow,"glutHideWindow",glutHideWindow,IO ())-API_ENTRY(dyn_glutIconifyWindow,ptr_glutIconifyWindow,"glutIconifyWindow",glutIconifyWindow,IO ())-API_ENTRY(dyn_glutIdleFunc,ptr_glutIdleFunc,"glutIdleFunc",glutIdleFunc,FunPtr IdleFunc -> IO ())-API_ENTRY(dyn_glutIgnoreKeyRepeat,ptr_glutIgnoreKeyRepeat,"glutIgnoreKeyRepeat",glutIgnoreKeyRepeat,CInt -> IO ())-API_ENTRY(dyn_glutInit,ptr_glutInit,"glutInit",glutInit,Ptr CInt -> Ptr (Ptr CChar) -> IO ())-API_ENTRY(dyn_glutInitContextFlags,ptr_glutInitContextFlags,"glutInitContextFlags",glutInitContextFlags,CInt -> IO ())-API_ENTRY(dyn_glutInitContextFunc,ptr_glutInitContextFunc,"glutInitContextFunc",glutInitContextFunc,FunPtr InitContextFunc -> IO ())-API_ENTRY(dyn_glutInitContextProfile,ptr_glutInitContextProfile,"glutInitContextProfile",glutInitContextProfile,CInt -> IO ())-API_ENTRY(dyn_glutInitContextVersion,ptr_glutInitContextVersion,"glutInitContextVersion",glutInitContextVersion,CInt -> CInt -> IO ())-API_ENTRY(dyn_glutInitDisplayMode,ptr_glutInitDisplayMode,"glutInitDisplayMode",glutInitDisplayMode,CUInt -> IO ())-API_ENTRY(dyn_glutInitDisplayString,ptr_glutInitDisplayString,"glutInitDisplayString",glutInitDisplayString,Ptr CChar -> IO ())-API_ENTRY(dyn_glutInitWindowPosition,ptr_glutInitWindowPosition,"glutInitWindowPosition",glutInitWindowPosition,CInt -> CInt -> IO ())-API_ENTRY(dyn_glutInitWindowSize,ptr_glutInitWindowSize,"glutInitWindowSize",glutInitWindowSize,CInt -> CInt -> IO ())-API_ENTRY(dyn_glutJoystickFunc,ptr_glutJoystickFunc,"glutJoystickFunc",glutJoystickFunc,FunPtr JoystickFunc -> CInt -> IO ())-API_ENTRY(dyn_glutKeyboardFunc,ptr_glutKeyboardFunc,"glutKeyboardFunc",glutKeyboardFunc,FunPtr KeyboardFunc -> IO ())-API_ENTRY(dyn_glutKeyboardUpFunc,ptr_glutKeyboardUpFunc,"glutKeyboardUpFunc",glutKeyboardUpFunc,FunPtr KeyboardUpFunc -> IO ())-API_ENTRY(dyn_glutLayerGet,ptr_glutLayerGet,"glutLayerGet",glutLayerGet,GLenum -> IO CInt)-API_ENTRY(dyn_glutLeaveFullScreen,ptr_glutLeaveFullScreen,"glutLeaveFullScreen",glutLeaveFullScreen,IO ())-API_ENTRY(dyn_glutLeaveGameMode,ptr_glutLeaveGameMode,"glutLeaveGameMode",glutLeaveGameMode,IO ())-API_ENTRY_SAFE(dyn_glutLeaveMainLoop,ptr_glutLeaveMainLoop,"glutLeaveMainLoop",glutLeaveMainLoop,IO ())-API_ENTRY_SAFE(dyn_glutMainLoop,ptr_glutMainLoop,"glutMainLoop",glutMainLoop,IO ())-API_ENTRY_SAFE(dyn_glutMainLoopEvent,ptr_glutMainLoopEvent,"glutMainLoopEvent",glutMainLoopEvent,IO ())-API_ENTRY(dyn_glutMenuDestroyFunc,ptr_glutMenuDestroyFunc,"glutMenuDestroyFunc",glutMenuDestroyFunc,FunPtr MenuDestroyFunc -> IO ())-API_ENTRY(dyn_glutMenuStateFunc,ptr_glutMenuStateFunc,"glutMenuStateFunc",glutMenuStateFunc,FunPtr MenuStateFunc -> IO ())-API_ENTRY(dyn_glutMenuStatusFunc,ptr_glutMenuStatusFunc,"glutMenuStatusFunc",glutMenuStatusFunc,FunPtr MenuStatusFunc -> IO ())-API_ENTRY(dyn_glutMotionFunc,ptr_glutMotionFunc,"glutMotionFunc",glutMotionFunc,FunPtr MotionFunc -> IO ())-API_ENTRY(dyn_glutMouseFunc,ptr_glutMouseFunc,"glutMouseFunc",glutMouseFunc,FunPtr MouseFunc -> IO ())-API_ENTRY(dyn_glutMouseWheelFunc,ptr_glutMouseWheelFunc,"glutMouseWheelFunc",glutMouseWheelFunc,FunPtr MouseWheelFunc -> IO ())-API_ENTRY(dyn_glutMultiButtonFunc,ptr_glutMultiButtonFunc,"glutMultiButtonFunc",glutMultiButtonFunc,FunPtr MultiButtonFunc -> IO ())-API_ENTRY(dyn_glutMultiEntryFunc,ptr_glutMultiEntryFunc,"glutMultiEntryFunc",glutMultiEntryFunc,FunPtr MultiEntryFunc -> IO ())-API_ENTRY(dyn_glutMultiMotionFunc,ptr_glutMultiMotionFunc,"glutMultiMotionFunc",glutMultiMotionFunc,FunPtr MultiMotionFunc -> IO ())-API_ENTRY(dyn_glutMultiPassiveFunc,ptr_glutMultiPassiveFunc,"glutMultiPassiveFunc",glutMultiPassiveFunc,FunPtr MultiPassiveFunc -> IO ())-API_ENTRY(dyn_glutOverlayDisplayFunc,ptr_glutOverlayDisplayFunc,"glutOverlayDisplayFunc",glutOverlayDisplayFunc,FunPtr OverlayDisplayFunc -> IO ())-API_ENTRY(dyn_glutPassiveMotionFunc,ptr_glutPassiveMotionFunc,"glutPassiveMotionFunc",glutPassiveMotionFunc,FunPtr PassiveMotionFunc -> IO ())-API_ENTRY(dyn_glutPopWindow,ptr_glutPopWindow,"glutPopWindow",glutPopWindow,IO ())-API_ENTRY(dyn_glutPositionFunc,ptr_glutPositionFunc,"glutPositionFunc",glutPositionFunc,FunPtr PositionFunc -> IO ())-API_ENTRY(dyn_glutPositionWindow,ptr_glutPositionWindow,"glutPositionWindow",glutPositionWindow,CInt -> CInt -> IO ())-API_ENTRY_SAFE(dyn_glutPostOverlayRedisplay,ptr_glutPostOverlayRedisplay,"glutPostOverlayRedisplay",glutPostOverlayRedisplay,IO ())-API_ENTRY(dyn_glutPostRedisplay,ptr_glutPostRedisplay,"glutPostRedisplay",glutPostRedisplay,IO ())-API_ENTRY_SAFE(dyn_glutPostWindowOverlayRedisplay,ptr_glutPostWindowOverlayRedisplay,"glutPostWindowOverlayRedisplay",glutPostWindowOverlayRedisplay,CInt -> IO ())-API_ENTRY(dyn_glutPostWindowRedisplay,ptr_glutPostWindowRedisplay,"glutPostWindowRedisplay",glutPostWindowRedisplay,CInt -> IO ())-API_ENTRY(dyn_glutPushWindow,ptr_glutPushWindow,"glutPushWindow",glutPushWindow,IO ())-API_ENTRY(dyn_glutRemoveMenuItem,ptr_glutRemoveMenuItem,"glutRemoveMenuItem",glutRemoveMenuItem,CInt -> IO ())-API_ENTRY_SAFE(dyn_glutRemoveOverlay,ptr_glutRemoveOverlay,"glutRemoveOverlay",glutRemoveOverlay,IO ())-API_ENTRY(dyn_glutReportErrors,ptr_glutReportErrors,"glutReportErrors",glutReportErrors,IO ())-API_ENTRY(dyn_glutReshapeFunc,ptr_glutReshapeFunc,"glutReshapeFunc",glutReshapeFunc,FunPtr ReshapeFunc -> IO ())-API_ENTRY(dyn_glutReshapeWindow,ptr_glutReshapeWindow,"glutReshapeWindow",glutReshapeWindow,CInt -> CInt -> IO ())-API_ENTRY(dyn_glutSetColor,ptr_glutSetColor,"glutSetColor",glutSetColor,CInt -> GLfloat -> GLfloat -> GLfloat -> IO ())-API_ENTRY(dyn_glutSetCursor,ptr_glutSetCursor,"glutSetCursor",glutSetCursor,CInt -> IO ())-API_ENTRY(dyn_glutSetIconTitle,ptr_glutSetIconTitle,"glutSetIconTitle",glutSetIconTitle,Ptr CChar -> IO ())-API_ENTRY(dyn_glutSetKeyRepeat,ptr_glutSetKeyRepeat,"glutSetKeyRepeat",glutSetKeyRepeat,CInt -> IO ())-API_ENTRY(dyn_glutSetMenu,ptr_glutSetMenu,"glutSetMenu",glutSetMenu,CInt -> IO ())-API_ENTRY(dyn_glutSetMenuData,ptr_glutSetMenuData,"glutSetMenuData",glutSetMenuData,Ptr a -> IO ())-API_ENTRY(dyn_glutSetMenuFont,ptr_glutSetMenuFont,"glutSetMenuFont",glutSetMenuFont,GLint -> Ptr a -> IO ())-API_ENTRY(dyn_glutSetOption,ptr_glutSetOption,"glutSetOption",glutSetOption,GLenum -> CInt -> IO ())-API_ENTRY(dyn_glutSetVertexAttribCoord3,ptr_glutSetVertexAttribCoord3,"glutSetVertexAttribCoord3",glutSetVertexAttribCoord3,GLint -> IO ())-API_ENTRY(dyn_glutSetVertexAttribNormal,ptr_glutSetVertexAttribNormal,"glutSetVertexAttribNormal",glutSetVertexAttribNormal,GLint -> IO ())-API_ENTRY(dyn_glutSetVertexAttribTexCoord2,ptr_glutSetVertexAttribTexCoord2,"glutSetVertexAttribTexCoord2",glutSetVertexAttribTexCoord2,GLint -> IO ())-API_ENTRY(dyn_glutSetWindow,ptr_glutSetWindow,"glutSetWindow",glutSetWindow,CInt -> IO ())-API_ENTRY(dyn_glutSetWindowData,ptr_glutSetWindowData,"glutSetWindowData",glutSetWindowData,Ptr a -> IO ())-API_ENTRY(dyn_glutSetWindowTitle,ptr_glutSetWindowTitle,"glutSetWindowTitle",glutSetWindowTitle,Ptr CChar -> IO ())-API_ENTRY(dyn_glutSetupVideoResizing,ptr_glutSetupVideoResizing,"glutSetupVideoResizing",glutSetupVideoResizing,IO ())-API_ENTRY_SAFE(dyn_glutShowOverlay,ptr_glutShowOverlay,"glutShowOverlay",glutShowOverlay,IO ())-API_ENTRY(dyn_glutShowWindow,ptr_glutShowWindow,"glutShowWindow",glutShowWindow,IO ())-API_ENTRY(dyn_glutSolidCone,ptr_glutSolidCone,"glutSolidCone",glutSolidCone,GLdouble -> GLdouble -> GLint -> GLint -> IO ())-API_ENTRY(dyn_glutSolidCube,ptr_glutSolidCube,"glutSolidCube",glutSolidCube,GLdouble -> IO ())-API_ENTRY(dyn_glutSolidCylinder,ptr_glutSolidCylinder,"glutSolidCylinder",glutSolidCylinder,GLdouble -> GLdouble -> GLint -> GLint -> IO ())-API_ENTRY(dyn_glutSolidDodecahedron,ptr_glutSolidDodecahedron,"glutSolidDodecahedron",glutSolidDodecahedron,IO ())-API_ENTRY(dyn_glutSolidIcosahedron,ptr_glutSolidIcosahedron,"glutSolidIcosahedron",glutSolidIcosahedron,IO ())-API_ENTRY(dyn_glutSolidOctahedron,ptr_glutSolidOctahedron,"glutSolidOctahedron",glutSolidOctahedron,IO ())-API_ENTRY(dyn_glutSolidRhombicDodecahedron,ptr_glutSolidRhombicDodecahedron,"glutSolidRhombicDodecahedron",glutSolidRhombicDodecahedron,IO ())-API_ENTRY(dyn_glutSolidSierpinskiSponge,ptr_glutSolidSierpinskiSponge,"glutSolidSierpinskiSponge",glutSolidSierpinskiSponge,CInt -> Ptr GLdouble -> GLdouble -> IO ())-API_ENTRY(dyn_glutSolidSphere,ptr_glutSolidSphere,"glutSolidSphere",glutSolidSphere,GLdouble -> GLint -> GLint -> IO ())-API_ENTRY(dyn_glutSolidTeacup,ptr_glutSolidTeacup,"glutSolidTeacup",glutSolidTeacup,GLdouble -> IO ())-API_ENTRY(dyn_glutSolidTeapot,ptr_glutSolidTeapot,"glutSolidTeapot",glutSolidTeapot,GLdouble -> IO ())-API_ENTRY(dyn_glutSolidTeaspoon,ptr_glutSolidTeaspoon,"glutSolidTeaspoon",glutSolidTeaspoon,GLdouble -> IO ())-API_ENTRY(dyn_glutSolidTetrahedron,ptr_glutSolidTetrahedron,"glutSolidTetrahedron",glutSolidTetrahedron,IO ())-API_ENTRY(dyn_glutSolidTorus,ptr_glutSolidTorus,"glutSolidTorus",glutSolidTorus,GLdouble -> GLdouble -> GLint -> GLint -> IO ())-API_ENTRY(dyn_glutSpaceballButtonFunc,ptr_glutSpaceballButtonFunc,"glutSpaceballButtonFunc",glutSpaceballButtonFunc,FunPtr SpaceballButtonFunc -> IO ())-API_ENTRY(dyn_glutSpaceballMotionFunc,ptr_glutSpaceballMotionFunc,"glutSpaceballMotionFunc",glutSpaceballMotionFunc,FunPtr SpaceballMotionFunc -> IO ())-API_ENTRY(dyn_glutSpaceballRotateFunc,ptr_glutSpaceballRotateFunc,"glutSpaceballRotateFunc",glutSpaceballRotateFunc,FunPtr SpaceballRotateFunc -> IO ())-API_ENTRY(dyn_glutSpecialFunc,ptr_glutSpecialFunc,"glutSpecialFunc",glutSpecialFunc,FunPtr SpecialFunc -> IO ())-API_ENTRY(dyn_glutSpecialUpFunc,ptr_glutSpecialUpFunc,"glutSpecialUpFunc",glutSpecialUpFunc,FunPtr SpecialUpFunc -> IO ())-API_ENTRY(dyn_glutStopVideoResizing,ptr_glutStopVideoResizing,"glutStopVideoResizing",glutStopVideoResizing,IO ())-API_ENTRY(dyn_glutStrokeCharacter,ptr_glutStrokeCharacter,"glutStrokeCharacter",glutStrokeCharacter,Ptr a -> CInt -> IO ())-API_ENTRY(dyn_glutStrokeHeight,ptr_glutStrokeHeight,"glutStrokeHeight",glutStrokeHeight,Ptr a -> IO GLfloat)-API_ENTRY(dyn_glutStrokeLength,ptr_glutStrokeLength,"glutStrokeLength",glutStrokeLength,Ptr a -> Ptr CUChar -> IO CInt)-API_ENTRY(dyn_glutStrokeString,ptr_glutStrokeString,"glutStrokeString",glutStrokeString,Ptr a -> Ptr CUChar -> IO ())-API_ENTRY(dyn_glutStrokeWidth,ptr_glutStrokeWidth,"glutStrokeWidth",glutStrokeWidth,Ptr a -> CInt -> IO CInt)-API_ENTRY(dyn_glutSwapBuffers,ptr_glutSwapBuffers,"glutSwapBuffers",glutSwapBuffers,IO ())-API_ENTRY(dyn_glutTabletButtonFunc,ptr_glutTabletButtonFunc,"glutTabletButtonFunc",glutTabletButtonFunc,FunPtr TabletButtonFunc -> IO ())-API_ENTRY(dyn_glutTabletMotionFunc,ptr_glutTabletMotionFunc,"glutTabletMotionFunc",glutTabletMotionFunc,FunPtr TabletMotionFunc -> IO ())-API_ENTRY(dyn_glutTimerFunc,ptr_glutTimerFunc,"glutTimerFunc",glutTimerFunc,CUInt -> FunPtr TimerFunc -> CInt -> IO ())-API_ENTRY_SAFE(dyn_glutUseLayer,ptr_glutUseLayer,"glutUseLayer",glutUseLayer,GLenum -> IO ())-API_ENTRY(dyn_glutVideoPan,ptr_glutVideoPan,"glutVideoPan",glutVideoPan,CInt -> CInt -> CInt -> CInt -> IO ())-API_ENTRY(dyn_glutVideoResize,ptr_glutVideoResize,"glutVideoResize",glutVideoResize,CInt -> CInt -> CInt -> CInt -> IO ())-API_ENTRY(dyn_glutVideoResizeGet,ptr_glutVideoResizeGet,"glutVideoResizeGet",glutVideoResizeGet,GLenum -> IO CInt)-API_ENTRY(dyn_glutVisibilityFunc,ptr_glutVisibilityFunc,"glutVisibilityFunc",glutVisibilityFunc,FunPtr VisibilityFunc -> IO ())-API_ENTRY(dyn_glutWMCloseFunc,ptr_glutWMCloseFunc,"glutWMCloseFunc",glutWMCloseFunc,FunPtr WMCloseFunc -> IO ())-API_ENTRY(dyn_glutWarpPointer,ptr_glutWarpPointer,"glutWarpPointer",glutWarpPointer,CInt -> CInt -> IO ())-API_ENTRY(dyn_glutWindowStatusFunc,ptr_glutWindowStatusFunc,"glutWindowStatusFunc",glutWindowStatusFunc,FunPtr WindowStatusFunc -> IO ())-API_ENTRY(dyn_glutWireCone,ptr_glutWireCone,"glutWireCone",glutWireCone,GLdouble -> GLdouble -> GLint -> GLint -> IO ())-API_ENTRY(dyn_glutWireCube,ptr_glutWireCube,"glutWireCube",glutWireCube,GLdouble -> IO ())-API_ENTRY(dyn_glutWireCylinder,ptr_glutWireCylinder,"glutWireCylinder",glutWireCylinder,GLdouble -> GLdouble -> GLint -> GLint -> IO ())-API_ENTRY(dyn_glutWireDodecahedron,ptr_glutWireDodecahedron,"glutWireDodecahedron",glutWireDodecahedron,IO ())-API_ENTRY(dyn_glutWireIcosahedron,ptr_glutWireIcosahedron,"glutWireIcosahedron",glutWireIcosahedron,IO ())-API_ENTRY(dyn_glutWireOctahedron,ptr_glutWireOctahedron,"glutWireOctahedron",glutWireOctahedron,IO ())-API_ENTRY(dyn_glutWireRhombicDodecahedron,ptr_glutWireRhombicDodecahedron,"glutWireRhombicDodecahedron",glutWireRhombicDodecahedron,IO ())-API_ENTRY(dyn_glutWireSierpinskiSponge,ptr_glutWireSierpinskiSponge,"glutWireSierpinskiSponge",glutWireSierpinskiSponge,CInt -> Ptr GLdouble -> GLdouble -> IO ())-API_ENTRY(dyn_glutWireSphere,ptr_glutWireSphere,"glutWireSphere",glutWireSphere,GLdouble -> GLint -> GLint -> IO ())-API_ENTRY(dyn_glutWireTeacup,ptr_glutWireTeacup,"glutWireTeacup",glutWireTeacup,GLdouble -> IO ())-API_ENTRY(dyn_glutWireTeapot,ptr_glutWireTeapot,"glutWireTeapot",glutWireTeapot,GLdouble -> IO ())-API_ENTRY(dyn_glutWireTeaspoon,ptr_glutWireTeaspoon,"glutWireTeaspoon",glutWireTeaspoon,GLdouble -> IO ())-API_ENTRY(dyn_glutWireTetrahedron,ptr_glutWireTetrahedron,"glutWireTetrahedron",glutWireTetrahedron,IO ())-API_ENTRY(dyn_glutWireTorus,ptr_glutWireTorus,"glutWireTorus",glutWireTorus,GLdouble -> GLdouble -> GLint -> GLint -> IO ())
− Graphics/UI/GLUT/Raw/Tokens.hs 
@@ -1,643 +0,0 @@-{-# OPTIONS_HADDOCK hide #-}--------------------------------------------------------------------------------- |--- Module      :  Graphics.UI.GLUT.Raw.Tokens--- Copyright   :  (c) Sven Panne 2013--- License     :  BSD3------ Maintainer  :  Sven Panne <svenpanne@gmail.com>--- Stability   :  stable--- Portability :  portable------ All tokens from GLUT and freeglut.-----------------------------------------------------------------------------------module Graphics.UI.GLUT.Raw.Tokens where--import Foreign.C.Types-import Graphics.Rendering.OpenGL ( GLenum )--glut_ACCUM :: CUInt-glut_ACCUM = 0x0004--glut_ACTION_CONTINUE_EXECUTION :: CInt-glut_ACTION_CONTINUE_EXECUTION = 2--glut_ACTION_EXIT :: CInt-glut_ACTION_EXIT = 0--glut_ACTION_GLUTMAINLOOP_RETURNS :: CInt-glut_ACTION_GLUTMAINLOOP_RETURNS = 1--glut_ACTION_ON_WINDOW_CLOSE :: GLenum-glut_ACTION_ON_WINDOW_CLOSE = 0x01F9--glut_ACTIVE_ALT :: CInt-glut_ACTIVE_ALT = 0x0004--glut_ACTIVE_CTRL :: CInt-glut_ACTIVE_CTRL = 0x0002--glut_ACTIVE_SHIFT :: CInt-glut_ACTIVE_SHIFT = 0x0001--glut_ALLOW_DIRECT_CONTEXT :: CInt-glut_ALLOW_DIRECT_CONTEXT = 1--glut_ALPHA :: CUInt-glut_ALPHA = 0x0008--glut_APPSTATUS_PAUSE :: CInt-glut_APPSTATUS_PAUSE = 0x0001--glut_APPSTATUS_RESUME :: CInt-glut_APPSTATUS_RESUME = 0x0002--glut_AUX :: GLenum-glut_AUX = 0x1000--glut_AUX1 :: CUInt-glut_AUX1 = 0x1000--glut_AUX2 :: CUInt-glut_AUX2 = 0x2000--glut_AUX3 :: CUInt-glut_AUX3 = 0x4000--glut_AUX4 :: CUInt-glut_AUX4 = 0x8000--glut_BLUE :: CInt-glut_BLUE = 0x0002--glut_BORDERLESS :: CUInt-glut_BORDERLESS = 0x0800--glut_CAPTIONLESS :: CUInt-glut_CAPTIONLESS = 0x0400--glut_CORE_PROFILE :: CInt-glut_CORE_PROFILE = 0x0001--glut_COMPATIBILITY_PROFILE :: CInt-glut_COMPATIBILITY_PROFILE = 0x0002--glut_CREATE_NEW_CONTEXT :: CInt-glut_CREATE_NEW_CONTEXT = 0--glut_CURSOR_BOTTOM_LEFT_CORNER :: CInt-glut_CURSOR_BOTTOM_LEFT_CORNER = 0x0013--glut_CURSOR_BOTTOM_RIGHT_CORNER :: CInt-glut_CURSOR_BOTTOM_RIGHT_CORNER = 0x0012--glut_CURSOR_BOTTOM_SIDE :: CInt-glut_CURSOR_BOTTOM_SIDE = 0x000D--glut_CURSOR_CROSSHAIR :: CInt-glut_CURSOR_CROSSHAIR = 0x0009--glut_CURSOR_CYCLE :: CInt-glut_CURSOR_CYCLE = 0x0005--glut_CURSOR_DESTROY :: CInt-glut_CURSOR_DESTROY = 0x0003--glut_CURSOR_FULL_CROSSHAIR :: CInt-glut_CURSOR_FULL_CROSSHAIR = 0x0066--glut_CURSOR_HELP :: CInt-glut_CURSOR_HELP = 0x0004--glut_CURSOR_INFO :: CInt-glut_CURSOR_INFO = 0x0002--glut_CURSOR_INHERIT :: CInt-glut_CURSOR_INHERIT = 0x0064--glut_CURSOR_LEFT_ARROW :: CInt-glut_CURSOR_LEFT_ARROW = 0x0001--glut_CURSOR_LEFT_RIGHT :: CInt-glut_CURSOR_LEFT_RIGHT = 0x000B--glut_CURSOR_LEFT_SIDE :: CInt-glut_CURSOR_LEFT_SIDE = 0x000E--glut_CURSOR_NONE :: CInt-glut_CURSOR_NONE = 0x0065--glut_CURSOR_RIGHT_ARROW :: CInt-glut_CURSOR_RIGHT_ARROW = 0x0000--glut_CURSOR_RIGHT_SIDE :: CInt-glut_CURSOR_RIGHT_SIDE = 0x000F--glut_CURSOR_SPRAY :: CInt-glut_CURSOR_SPRAY = 0x0006--glut_CURSOR_TEXT :: CInt-glut_CURSOR_TEXT = 0x0008--glut_CURSOR_TOP_LEFT_CORNER :: CInt-glut_CURSOR_TOP_LEFT_CORNER = 0x0010--glut_CURSOR_TOP_RIGHT_CORNER :: CInt-glut_CURSOR_TOP_RIGHT_CORNER = 0x0011--glut_CURSOR_TOP_SIDE :: CInt-glut_CURSOR_TOP_SIDE = 0x000C--glut_CURSOR_UP_DOWN :: CInt-glut_CURSOR_UP_DOWN = 0x000A--glut_CURSOR_WAIT :: CInt-glut_CURSOR_WAIT = 0x0007--glut_DEBUG :: CInt-glut_DEBUG = 0x0001--glut_DEPTH :: CUInt-glut_DEPTH = 0x0010--glut_DEVICE_IGNORE_KEY_REPEAT :: GLenum-glut_DEVICE_IGNORE_KEY_REPEAT = 0x0262--glut_DEVICE_KEY_REPEAT :: GLenum-glut_DEVICE_KEY_REPEAT = 0x0263--glut_DIRECT_RENDERING :: GLenum-glut_DIRECT_RENDERING = 0x01FE--glut_DISPLAY_MODE_POSSIBLE :: GLenum-glut_DISPLAY_MODE_POSSIBLE = 0x0190--glut_DOUBLE :: CUInt-glut_DOUBLE = 0x0002--glut_DOWN :: CInt-glut_DOWN = 0x0000--glut_ELAPSED_TIME :: GLenum-glut_ELAPSED_TIME = 0x02BC--glut_ENTERED :: CInt-glut_ENTERED = 0x0001--glut_FORCE_DIRECT_CONTEXT :: CInt-glut_FORCE_DIRECT_CONTEXT = 3--glut_FORCE_INDIRECT_CONTEXT :: CInt-glut_FORCE_INDIRECT_CONTEXT = 0--glut_FORWARD_COMPATIBLE :: CInt-glut_FORWARD_COMPATIBLE = 0x0002--glut_FULLY_COVERED :: CInt-glut_FULLY_COVERED = 0x0003--glut_FULLY_RETAINED :: CInt-glut_FULLY_RETAINED = 0x0001--glut_FULL_SCREEN :: GLenum-glut_FULL_SCREEN = 0x01FF--glut_GAME_MODE_ACTIVE :: GLenum-glut_GAME_MODE_ACTIVE = 0x0000--glut_GAME_MODE_DISPLAY_CHANGED :: GLenum-glut_GAME_MODE_DISPLAY_CHANGED = 0x0006--glut_GAME_MODE_HEIGHT :: GLenum-glut_GAME_MODE_HEIGHT = 0x0003--glut_GAME_MODE_PIXEL_DEPTH :: GLenum-glut_GAME_MODE_PIXEL_DEPTH = 0x0004--glut_GAME_MODE_POSSIBLE :: GLenum-glut_GAME_MODE_POSSIBLE = 0x0001--glut_GAME_MODE_REFRESH_RATE :: GLenum-glut_GAME_MODE_REFRESH_RATE = 0x0005--glut_GAME_MODE_WIDTH :: GLenum-glut_GAME_MODE_WIDTH = 0x0002--glut_GEOMETRY_VISUALIZE_NORMALS :: GLenum-glut_GEOMETRY_VISUALIZE_NORMALS = 0x0205--glut_GREEN :: CInt-glut_GREEN = 0x0001--glut_HAS_DIAL_AND_BUTTON_BOX :: GLenum-glut_HAS_DIAL_AND_BUTTON_BOX = 0x025B--glut_HAS_JOYSTICK :: GLenum-glut_HAS_JOYSTICK = 0x0264--glut_HAS_KEYBOARD :: GLenum-glut_HAS_KEYBOARD = 0x0258--glut_HAS_MOUSE :: GLenum-glut_HAS_MOUSE = 0x0259--glut_HAS_OVERLAY :: GLenum-glut_HAS_OVERLAY = 0x0322--glut_HAS_SPACEBALL :: GLenum-glut_HAS_SPACEBALL = 0x025A--glut_HAS_TABLET :: GLenum-glut_HAS_TABLET = 0x025C--glut_HIDDEN :: CInt-glut_HIDDEN = 0x0000--glut_INDEX :: CUInt-glut_INDEX = 0x0001--glut_INIT_DISPLAY_MODE :: GLenum-glut_INIT_DISPLAY_MODE = 0x01F8--glut_INIT_FLAGS :: GLenum-glut_INIT_FLAGS = 0x0202--glut_INIT_MAJOR_VERSION :: GLenum-glut_INIT_MAJOR_VERSION = 0x0200--glut_INIT_MINOR_VERSION :: GLenum-glut_INIT_MINOR_VERSION = 0x0201--glut_INIT_PROFILE :: GLenum-glut_INIT_PROFILE = 0x0203--glut_INIT_STATE :: GLenum-glut_INIT_STATE = 0x007C--glut_INIT_WINDOW_HEIGHT :: GLenum-glut_INIT_WINDOW_HEIGHT = 0x01F7--glut_INIT_WINDOW_WIDTH :: GLenum-glut_INIT_WINDOW_WIDTH = 0x01F6--glut_INIT_WINDOW_X :: GLenum-glut_INIT_WINDOW_X = 0x01F4--glut_INIT_WINDOW_Y :: GLenum-glut_INIT_WINDOW_Y = 0x01F5--glut_JOYSTICK_AXES :: GLenum-glut_JOYSTICK_AXES = 0x0267--glut_JOYSTICK_BUTTONS :: GLenum-glut_JOYSTICK_BUTTONS = 0x0266--glut_JOYSTICK_BUTTON_A :: CUInt-glut_JOYSTICK_BUTTON_A = 0x0001--glut_JOYSTICK_BUTTON_B :: CUInt-glut_JOYSTICK_BUTTON_B = 0x0002--glut_JOYSTICK_BUTTON_C :: CUInt-glut_JOYSTICK_BUTTON_C = 0x0004--glut_JOYSTICK_BUTTON_D :: CUInt-glut_JOYSTICK_BUTTON_D = 0x0008--glut_JOYSTICK_POLL_RATE :: GLenum-glut_JOYSTICK_POLL_RATE = 0x0268--glut_KEY_ALT_L :: CInt-glut_KEY_ALT_L = 0x0074--glut_KEY_ALT_R :: CInt-glut_KEY_ALT_R = 0x0075--glut_KEY_BEGIN :: CInt-glut_KEY_BEGIN = 0x006E--glut_KEY_CTRL_L :: CInt-glut_KEY_CTRL_L = 0x0072--glut_KEY_CTRL_R :: CInt-glut_KEY_CTRL_R = 0x0073--glut_KEY_DELETE :: CInt-glut_KEY_DELETE = 0x006F--glut_KEY_DOWN :: CInt-glut_KEY_DOWN = 0x0067--glut_KEY_END :: CInt-glut_KEY_END = 0x006B--glut_KEY_F1 :: CInt-glut_KEY_F1 = 0x0001--glut_KEY_F10 :: CInt-glut_KEY_F10 = 0x000A--glut_KEY_F11 :: CInt-glut_KEY_F11 = 0x000B--glut_KEY_F12 :: CInt-glut_KEY_F12 = 0x000C--glut_KEY_F2 :: CInt-glut_KEY_F2 = 0x0002--glut_KEY_F3 :: CInt-glut_KEY_F3 = 0x0003--glut_KEY_F4 :: CInt-glut_KEY_F4 = 0x0004--glut_KEY_F5 :: CInt-glut_KEY_F5 = 0x0005--glut_KEY_F6 :: CInt-glut_KEY_F6 = 0x0006--glut_KEY_F7 :: CInt-glut_KEY_F7 = 0x0007--glut_KEY_F8 :: CInt-glut_KEY_F8 = 0x0008--glut_KEY_F9 :: CInt-glut_KEY_F9 = 0x0009--glut_KEY_HOME :: CInt-glut_KEY_HOME = 0x006A--glut_KEY_INSERT :: CInt-glut_KEY_INSERT = 0x006C--glut_KEY_LEFT :: CInt-glut_KEY_LEFT = 0x0064--glut_KEY_NUM_LOCK :: CInt-glut_KEY_NUM_LOCK = 0x006D--glut_KEY_PAGE_DOWN :: CInt-glut_KEY_PAGE_DOWN = 0x0069--glut_KEY_PAGE_UP :: CInt-glut_KEY_PAGE_UP = 0x0068--glut_KEY_REPEAT_DEFAULT :: CInt-glut_KEY_REPEAT_DEFAULT = 0x0002--glut_KEY_REPEAT_OFF :: CInt-glut_KEY_REPEAT_OFF = 0x0000--glut_KEY_REPEAT_ON :: CInt-glut_KEY_REPEAT_ON = 0x0001--glut_KEY_RIGHT :: CInt-glut_KEY_RIGHT = 0x0066--glut_KEY_SHIFT_L :: CInt-glut_KEY_SHIFT_L = 0x0070--glut_KEY_SHIFT_R :: CInt-glut_KEY_SHIFT_R = 0x0071--glut_KEY_UP :: CInt-glut_KEY_UP = 0x0065--glut_LAYER_IN_USE :: GLenum-glut_LAYER_IN_USE = 0x0321--glut_LEFT :: CInt-glut_LEFT = 0x0000--glut_LEFT_BUTTON :: CInt-glut_LEFT_BUTTON = 0x0000--glut_LUMINANCE :: CUInt-glut_LUMINANCE = 0x0200--glut_MENU_IN_USE :: CInt-glut_MENU_IN_USE = 0x0001--glut_MENU_NOT_IN_USE :: CInt-glut_MENU_NOT_IN_USE = 0x0000--glut_MENU_NUM_ITEMS :: GLenum-glut_MENU_NUM_ITEMS = 0x012C--glut_MIDDLE_BUTTON :: CInt-glut_MIDDLE_BUTTON = 0x0001--glut_MULTISAMPLE :: CUInt-glut_MULTISAMPLE = 0x0080--glut_NORMAL :: GLenum-glut_NORMAL = 0x0000--glut_NORMAL_DAMAGED :: GLenum-glut_NORMAL_DAMAGED = 0x0324--glut_NOT_VISIBLE :: CInt-glut_NOT_VISIBLE = 0x0000--glut_NUM_BUTTON_BOX_BUTTONS :: GLenum-glut_NUM_BUTTON_BOX_BUTTONS = 0x025F--glut_NUM_DIALS :: GLenum-glut_NUM_DIALS = 0x0260--glut_NUM_MOUSE_BUTTONS :: GLenum-glut_NUM_MOUSE_BUTTONS = 0x025D--glut_NUM_SPACEBALL_BUTTONS :: GLenum-glut_NUM_SPACEBALL_BUTTONS = 0x025E--glut_NUM_TABLET_BUTTONS :: GLenum-glut_NUM_TABLET_BUTTONS = 0x0261--glut_OVERLAY :: GLenum-glut_OVERLAY = 0x0001--glut_OVERLAY_DAMAGED :: GLenum-glut_OVERLAY_DAMAGED = 0x0325--glut_OVERLAY_POSSIBLE :: GLenum-glut_OVERLAY_POSSIBLE = 0x0320--glut_OWNS_JOYSTICK :: GLenum-glut_OWNS_JOYSTICK = 0x0265--glut_PARTIALLY_RETAINED :: CInt-glut_PARTIALLY_RETAINED = 0x0002--glut_RED :: CInt-glut_RED = 0x0000--glut_RENDERING_CONTEXT :: GLenum-glut_RENDERING_CONTEXT = 0x01FD--glut_RGB :: CUInt-glut_RGB = 0x0000--glut_RGBA :: CUInt-glut_RGBA = 0x0000--glut_RIGHT_BUTTON :: CInt-glut_RIGHT_BUTTON = 0x0002--glut_SCREEN_HEIGHT :: GLenum-glut_SCREEN_HEIGHT = 0x00C9--glut_SCREEN_HEIGHT_MM :: GLenum-glut_SCREEN_HEIGHT_MM = 0x00CB--glut_SCREEN_WIDTH :: GLenum-glut_SCREEN_WIDTH = 0x00C8--glut_SCREEN_WIDTH_MM :: GLenum-glut_SCREEN_WIDTH_MM = 0x00CA--glut_SINGLE :: CUInt-glut_SINGLE = 0x0000--glut_SKIP_STALE_MOTION_EVENTS :: GLenum-glut_SKIP_STALE_MOTION_EVENTS = 0x0204--glut_SRGB :: CUInt-glut_SRGB = 0x1000--glut_STENCIL :: CUInt-glut_STENCIL = 0x0020--glut_STEREO :: CUInt-glut_STEREO = 0x0100--glut_TRANSPARENT_INDEX :: GLenum-glut_TRANSPARENT_INDEX = 0x0323--glut_TRY_DIRECT_CONTEXT :: CInt-glut_TRY_DIRECT_CONTEXT = 2--glut_UP :: CInt-glut_UP = 0x0001--glut_USE_CURRENT_CONTEXT :: CInt-glut_USE_CURRENT_CONTEXT = 1--glut_VERSION :: GLenum-glut_VERSION = 0x01FC--glut_VIDEO_RESIZE_HEIGHT :: GLenum-glut_VIDEO_RESIZE_HEIGHT = 0x038D--glut_VIDEO_RESIZE_HEIGHT_DELTA :: GLenum-glut_VIDEO_RESIZE_HEIGHT_DELTA = 0x0389--glut_VIDEO_RESIZE_IN_USE :: GLenum-glut_VIDEO_RESIZE_IN_USE = 0x0385--glut_VIDEO_RESIZE_POSSIBLE :: GLenum-glut_VIDEO_RESIZE_POSSIBLE = 0x0384--glut_VIDEO_RESIZE_WIDTH :: GLenum-glut_VIDEO_RESIZE_WIDTH = 0x038C--glut_VIDEO_RESIZE_WIDTH_DELTA :: GLenum-glut_VIDEO_RESIZE_WIDTH_DELTA = 0x0388--glut_VIDEO_RESIZE_X :: GLenum-glut_VIDEO_RESIZE_X = 0x038A--glut_VIDEO_RESIZE_X_DELTA :: GLenum-glut_VIDEO_RESIZE_X_DELTA = 0x0386--glut_VIDEO_RESIZE_Y :: GLenum-glut_VIDEO_RESIZE_Y = 0x038B--glut_VIDEO_RESIZE_Y_DELTA :: GLenum-glut_VIDEO_RESIZE_Y_DELTA = 0x0387--glut_VISIBLE :: CInt-glut_VISIBLE = 0x0001--glut_WINDOW_ACCUM_ALPHA_SIZE :: GLenum-glut_WINDOW_ACCUM_ALPHA_SIZE = 0x0072--glut_WINDOW_ACCUM_BLUE_SIZE :: GLenum-glut_WINDOW_ACCUM_BLUE_SIZE = 0x0071--glut_WINDOW_ACCUM_GREEN_SIZE :: GLenum-glut_WINDOW_ACCUM_GREEN_SIZE = 0x0070--glut_WINDOW_ACCUM_RED_SIZE :: GLenum-glut_WINDOW_ACCUM_RED_SIZE = 0x006F--glut_WINDOW_ALPHA_SIZE :: GLenum-glut_WINDOW_ALPHA_SIZE = 0x006E--glut_WINDOW_BLUE_SIZE :: GLenum-glut_WINDOW_BLUE_SIZE = 0x006D--glut_WINDOW_BORDER_WIDTH :: GLenum-glut_WINDOW_BORDER_WIDTH = 0x01FA--glut_WINDOW_BUFFER_SIZE :: GLenum-glut_WINDOW_BUFFER_SIZE = 0x0068--glut_WINDOW_COLORMAP_SIZE :: GLenum-glut_WINDOW_COLORMAP_SIZE = 0x0077--glut_WINDOW_CURSOR :: GLenum-glut_WINDOW_CURSOR = 0x007A--glut_WINDOW_DEPTH_SIZE :: GLenum-glut_WINDOW_DEPTH_SIZE = 0x006A--glut_WINDOW_DOUBLEBUFFER :: GLenum-glut_WINDOW_DOUBLEBUFFER = 0x0073--glut_WINDOW_FORMAT_ID :: GLenum-glut_WINDOW_FORMAT_ID = 0x007B--glut_WINDOW_GREEN_SIZE :: GLenum-glut_WINDOW_GREEN_SIZE = 0x006C--glut_WINDOW_HEADER_HEIGHT :: GLenum-glut_WINDOW_HEADER_HEIGHT = 0x01FB--glut_WINDOW_HEIGHT :: GLenum-glut_WINDOW_HEIGHT = 0x0067--glut_WINDOW_NUM_CHILDREN :: GLenum-glut_WINDOW_NUM_CHILDREN = 0x0076--glut_WINDOW_NUM_SAMPLES :: GLenum-glut_WINDOW_NUM_SAMPLES = 0x0078--glut_WINDOW_PARENT :: GLenum-glut_WINDOW_PARENT = 0x0075--glut_WINDOW_RED_SIZE :: GLenum-glut_WINDOW_RED_SIZE = 0x006B--glut_WINDOW_RGBA :: GLenum-glut_WINDOW_RGBA = 0x0074--glut_WINDOW_STENCIL_SIZE :: GLenum-glut_WINDOW_STENCIL_SIZE = 0x0069--glut_WINDOW_STEREO :: GLenum-glut_WINDOW_STEREO = 0x0079--glut_WINDOW_WIDTH :: GLenum-glut_WINDOW_WIDTH = 0x0066--glut_WINDOW_X :: GLenum-glut_WINDOW_X = 0x0064--glut_WINDOW_Y :: GLenum-glut_WINDOW_Y = 0x0065
− Graphics/UI/GLUT/State.hs 
@@ -1,446 +0,0 @@------------------------------------------------------------------------------------ |--- Module      :  Graphics.UI.GLUT.State--- Copyright   :  (c) Sven Panne 2002-2013--- License     :  BSD3------ Maintainer  :  Sven Panne <svenpanne@gmail.com>--- Stability   :  stable--- Portability :  portable------ GLUT maintains a considerable amount of programmer visible state. Some (but--- not all) of this state may be directly retrieved.--------------------------------------------------------------------------------------module Graphics.UI.GLUT.State (-   -- * State of all windows-   windowBorderWidth, windowHeaderHeight, skipStaleMotionEvents,--   -- * State of the /current window/--   -- ** Framebuffer state-   rgba,-   BufferDepth, rgbaBufferDepths, colorBufferDepth,-   doubleBuffered, stereo,-   accumBufferDepths, depthBufferDepth, stencilBufferDepth,-   SampleCount, sampleCount, formatID,--   -- ** Full screen state-   fullScreenMode,--   -- ** Object rendering state-   geometryVisualizeNormals,--   -- ** Vertex attribute state-   vertexAttribCoord3, vertexAttribNormal, vertexAttribTexCoord2,--   -- ** Layer state-   damaged,--   -- * Timing-   elapsedTime,--   -- * Device information--   -- $DeviceInformation-   screenSize, screenSizeMM,-   hasKeyboard,-   ButtonCount, numMouseButtons,-   numSpaceballButtons,-   DialCount, numDialsAndButtons,-   numTabletButtons,-   AxisCount, PollRate, joystickInfo,-   supportedNumAuxBuffers, supportedSamplesPerPixel,--   -- * GLUT information-   glutVersion, initState-) where--import Control.Monad-import Foreign.C.Types-import Foreign.Marshal.Alloc-import Foreign.Marshal.Array-import Foreign.Ptr-import Foreign.Storable-import Graphics.Rendering.OpenGL-import Graphics.UI.GLUT.Overlay-import Graphics.UI.GLUT.QueryUtils-import Graphics.UI.GLUT.Raw-import Graphics.UI.GLUT.Window-------------------------------------------------------------------------------------- | Contains 'True' when the current layer of the /current window/ is in RGBA--- mode, 'False' means color index mode.--rgba :: GettableStateVar Bool-rgba = makeGettableStateVar$ simpleGet i2b glut_WINDOW_RGBA---- | Bit depth of a buffer--type BufferDepth = Int---- | Contains the number of red, green, blue, and alpha bits in the color buffer--- of the /current window\'s/ current layer (0 in color index mode).--rgbaBufferDepths ::-   GettableStateVar (BufferDepth, BufferDepth, BufferDepth, BufferDepth)-rgbaBufferDepths = makeGettableStateVar $ do-   r <- simpleGet fromIntegral glut_WINDOW_RED_SIZE-   g <- simpleGet fromIntegral glut_WINDOW_GREEN_SIZE-   b <- simpleGet fromIntegral glut_WINDOW_BLUE_SIZE-   a <- simpleGet fromIntegral glut_WINDOW_ALPHA_SIZE-   return (r, g, b, a)---- | Contains the total number of bits in the color buffer of the /current--- window\'s/ current layer. For an RGBA layer, this is the sum of the red,--- green, blue, and alpha bits. For an color index layer, this is the number--- of bits of the color indexes.--colorBufferDepth :: GettableStateVar BufferDepth-colorBufferDepth =-   makeGettableStateVar $ simpleGet fromIntegral glut_WINDOW_BUFFER_SIZE---- | Contains 'True' when the current layer of the /current window/ is double--- buffered, 'False' otherwise.--doubleBuffered :: GettableStateVar Bool-doubleBuffered = makeGettableStateVar $ simpleGet i2b glut_WINDOW_DOUBLEBUFFER---- | Contains 'True' when the current layer of the /current window/ is stereo,--- 'False' otherwise.--stereo :: GettableStateVar Bool-stereo = makeGettableStateVar $ simpleGet i2b glut_WINDOW_STEREO---- | Contains the number of red, green, blue, and alpha bits in the accumulation--- buffer of the /current window\'s/ current layer (0 in color index mode).--accumBufferDepths ::-   GettableStateVar (BufferDepth, BufferDepth, BufferDepth, BufferDepth)-accumBufferDepths = makeGettableStateVar $ do-   r <- simpleGet fromIntegral glut_WINDOW_ACCUM_RED_SIZE-   g <- simpleGet fromIntegral glut_WINDOW_ACCUM_GREEN_SIZE-   b <- simpleGet fromIntegral glut_WINDOW_ACCUM_BLUE_SIZE-   a <- simpleGet fromIntegral glut_WINDOW_ACCUM_ALPHA_SIZE-   return (r, g, b, a)---- | Contains the number of bits in the depth buffer of the /current window\'s/--- current layer.--depthBufferDepth :: GettableStateVar BufferDepth-depthBufferDepth =-   makeGettableStateVar $ simpleGet fromIntegral glut_WINDOW_DEPTH_SIZE---- | Contains the number of bits in the stencil buffer of the /current--- window\'s/ current layer.--stencilBufferDepth :: GettableStateVar BufferDepth-stencilBufferDepth =-   makeGettableStateVar $ simpleGet fromIntegral glut_WINDOW_STENCIL_SIZE---- | Number of samples for multisampling--type SampleCount = Int---- | Contains the number of samples for multisampling for the /current window./--sampleCount :: GettableStateVar SampleCount-sampleCount =-   makeGettableStateVar $ simpleGet fromIntegral glut_WINDOW_NUM_SAMPLES---- | Contains the window system dependent format ID for the current layer of the--- /current window/. On X11 GLUT implementations, this is the X visual ID. On--- Win32 GLUT implementations, this is the Win32 Pixel Format Descriptor number.--- This value is returned for debugging, benchmarking, and testing ease.--formatID :: GettableStateVar Int-formatID = makeGettableStateVar $ simpleGet fromIntegral glut_WINDOW_FORMAT_ID-------------------------------------------------------------------------------------- | (/freeglut only/) Contains 'True' if the /current window/ is in full screen--- mode, 'False' otherwise.--fullScreenMode :: StateVar Bool-fullScreenMode = makeStateVar getFullScreenMode setFullScreenMode--getFullScreenMode :: IO Bool-getFullScreenMode = simpleGet i2b glut_FULL_SCREEN--setFullScreenMode :: Bool -> IO ()-setFullScreenMode newMode = do-   oldMode <- getFullScreenMode-   unless (newMode == oldMode) fullScreenToggle-------------------------------------------------------------------------------------- | (/freeglut only/) Controls if vectors representing the normals should be--- drawn, too, when objects are drawn.--geometryVisualizeNormals :: StateVar Bool-geometryVisualizeNormals =-   makeStateVar-      (simpleGet i2b glut_GEOMETRY_VISUALIZE_NORMALS)-      (glutSetOption glut_GEOMETRY_VISUALIZE_NORMALS . b2i)--------------------------------------------------------------------------------------- | (/freeglut only/) If 'vertexAttribCoord3' and 'vertexAttribNormal' both--- contain 'Nothing', the fixed function pipeline is used to draw--- objects. Otherwise VBOs are used and the coordinates are passed via 'Just'--- this attribute location (for a vec3).--vertexAttribCoord3 :: SettableStateVar (Maybe AttribLocation)-vertexAttribCoord3 = setVertexAttribWith glutSetVertexAttribCoord3--setVertexAttribWith :: (GLint -> IO ()) -> SettableStateVar (Maybe AttribLocation)-setVertexAttribWith f = makeSettableStateVar $ f . getLocation-   where getLocation = maybe (-1) (\(AttribLocation l) -> fromIntegral l)---- | (/freeglut only/) If 'vertexAttribCoord3' and 'vertexAttribNormal' both--- contain 'Nothing', the fixed function pipeline is used to draw--- objects. Otherwise VBOs are used and the normals are passed via 'Just' this--- attribute location (for a vec3).--vertexAttribNormal :: SettableStateVar (Maybe AttribLocation)-vertexAttribNormal = setVertexAttribWith glutSetVertexAttribNormal---- | (/freeglut only/) If VBOs are used to draw objects (controlled via--- 'vertexAttribCoord3' and 'vertexAttribNormal'), the texture coordinates are--- passed via 'Just' this attribute location (for a vec2).--vertexAttribTexCoord2 :: SettableStateVar (Maybe AttribLocation)-vertexAttribTexCoord2 = setVertexAttribWith glutSetVertexAttribTexCoord2-------------------------------------------------------------------------------------- | Contains the number of milliseconds since--- 'Graphics.UI.GLUT.Initialization.initialize' was called.--elapsedTime :: GettableStateVar Int-elapsedTime = makeGettableStateVar $ simpleGet fromIntegral glut_ELAPSED_TIME-------------------------------------------------------------------------------------- | Contains 'True' if the given plane of the /current window/ has been--- damaged (by window system activity) since the last display callback was--- triggered. Calling 'Graphics.UI.GLUT.Window.postRedisplay' or--- 'Graphics.UI.GLUT.Overlay.postOverlayRedisplay' will not set this 'True'.--damaged :: Layer -> GettableStateVar Bool-damaged l = makeGettableStateVar $ layerGet isDamaged (marshalDamagedLayer l)-   where isDamaged d = d /= 0 && d /= -1-         marshalDamagedLayer x = case x of-            Normal -> glut_NORMAL_DAMAGED-            Overlay -> glut_OVERLAY_DAMAGED-------------------------------------------------------------------------------------- $DeviceInformation--- If a device is not available, the following state variables contain--- 'Nothing', otherwise they return 'Just' the specific device information.--- Only a screen is always assumed.-------------------------------------------------------------------------------------- | The size of the screen in pixels.--screenSize :: GettableStateVar Size-screenSize =-   makeGettableStateVar $ do-      wpx <- simpleGet fromIntegral glut_SCREEN_WIDTH-      hpx <- simpleGet fromIntegral glut_SCREEN_HEIGHT-      return $ Size wpx hpx---- | The size of the screen in millimeters.--screenSizeMM :: GettableStateVar Size-screenSizeMM =-   makeGettableStateVar $ do-      wmm <- simpleGet fromIntegral glut_SCREEN_WIDTH_MM-      hmm <- simpleGet fromIntegral glut_SCREEN_HEIGHT_MM-      return $ Size wmm hmm-------------------------------------------------------------------------------------- | Contains 'True' if a keyboard is present, 'False' otherwise.--hasKeyboard :: GettableStateVar Bool-hasKeyboard = makeGettableStateVar $ deviceGet i2b glut_HAS_KEYBOARD-------------------------------------------------------------------------------------- | Number of buttons of an input device--type ButtonCount = Int---- | Contains 'Just' the number of buttons of an attached mouse or 'Nothing' if--- there is none.--numMouseButtons :: GettableStateVar (Maybe ButtonCount)-numMouseButtons =-   getDeviceInfo glut_HAS_MOUSE $-      deviceGet fromIntegral glut_NUM_MOUSE_BUTTONS-------------------------------------------------------------------------------------- | Contains 'Just' the number of buttons of the attached Spaceball or 'Nothing'--- if there is none.--numSpaceballButtons :: GettableStateVar (Maybe ButtonCount)-numSpaceballButtons =-   getDeviceInfo glut_HAS_SPACEBALL $-      deviceGet fromIntegral glut_NUM_SPACEBALL_BUTTONS-------------------------------------------------------------------------------------- | Number of dials of a dial and button box--type DialCount = Int---- | Contains 'Just' the number of dials and buttons of an attached dial &--- button box or 'Nothing' if there is none.--numDialsAndButtons :: GettableStateVar (Maybe (DialCount, ButtonCount))-numDialsAndButtons =-   getDeviceInfo glut_HAS_DIAL_AND_BUTTON_BOX $ do-      d <- deviceGet fromIntegral glut_NUM_DIALS-      b <- deviceGet fromIntegral glut_NUM_BUTTON_BOX_BUTTONS-      return (d, b)-------------------------------------------------------------------------------------- | Contains 'Just' the number of buttons of an attached tablet or 'Nothing' if--- there is none.--numTabletButtons :: GettableStateVar (Maybe ButtonCount)-numTabletButtons =-   getDeviceInfo glut_HAS_TABLET $-      deviceGet fromIntegral glut_NUM_TABLET_BUTTONS-------------------------------------------------------------------------------------- | Number of axes of a joystick--type AxisCount = Int---- | The a rate at which a joystick is polled (in milliseconds)--type PollRate = Int---- | Contains 'Just' the number of buttons of an attached joystick, the number--- of joystick axes, and the rate at which the joystick is polled. Contains--- 'Nothing' if there is no joystick attached.--joystickInfo :: GettableStateVar (Maybe (ButtonCount, PollRate, AxisCount))-joystickInfo =-   getDeviceInfo glut_HAS_JOYSTICK $ do-      b <- deviceGet fromIntegral glut_JOYSTICK_BUTTONS-      a <- deviceGet fromIntegral glut_JOYSTICK_AXES-      r <- deviceGet fromIntegral glut_JOYSTICK_POLL_RATE-      return (b, a, r)----------------------------------------------------------------------------------- | (/freeglut only/) Contains a list of the number of auxiliary buffers--- supported, in increasing order.--supportedNumAuxBuffers :: GettableStateVar [Int]-supportedNumAuxBuffers = getModeValues glut_AUX---- | (/freeglut only/) Contains a list of the number of samples per pixel--- supported for multisampling, in increasing order.--supportedSamplesPerPixel :: GettableStateVar [SampleCount]-supportedSamplesPerPixel = getModeValues (fromIntegral glut_MULTISAMPLE)--getModeValues :: Integral a => GLenum -> GettableStateVar [a]-getModeValues what = makeGettableStateVar $-   alloca $ \sizeBuffer -> do-      valuesBuffer <- glutGetModeValues what sizeBuffer-      size <- peek sizeBuffer-      fmap (map fromIntegral) $ peekArray (fromIntegral size) valuesBuffer------------------------------------------------------------------------------------- Convenience (un-)marshalers--i2b :: CInt -> Bool-i2b = (/= 0)--b2i :: Bool ->  CInt-b2i False = 0-b2i True = 1------------------------------------------------------------------------------------getDeviceInfo :: GLenum -> IO a -> GettableStateVar (Maybe a)-getDeviceInfo dev act =-   makeGettableStateVar $ do-      hasDevice <- deviceGet i2b dev-      if hasDevice then fmap Just act else return Nothing----------------------------------------------------------------------------------- | Contains version of GLUT in the form of--- @/flavour/ /major/./minor/./patchlevel/@, where @/flavour/@ is one of--- @GLUT@, @freeglut@ or @OpenGLUT@.--glutVersion :: GettableStateVar String-glutVersion = makeGettableStateVar $ do-   let isGLUT = isUnknown "glutSetOption"-       isFreeglut = isUnknown "glutSetWindowStayOnTop"-       isUnknown = fmap (== nullFunPtr) . getAPIEntryInternal-       showVersionPart x = shows (x `mod` 100)-       showVersion v = showVersionPart (v `div` 10000) . showChar '.' .-                       showVersionPart (v `div`   100) . showChar '.' .-                       showVersionPart  v-   g <- isGLUT-   if g-      then return "GLUT 3.7"   -- ToDo: just guessing-      else do f <- isFreeglut-              v <- simpleGet id glut_VERSION-              let prefix = if f then "freeglut" else "OpenGLUT"-              return $ showString prefix . showChar ' ' . showVersion v $ ""----------------------------------------------------------------------------------- | (/freeglut only/) Contains the thickness of the sizing border around the--- perimeter of a window that can be resized, in pixels.--windowBorderWidth :: GettableStateVar Int-windowBorderWidth =-   makeGettableStateVar (simpleGet fromIntegral glut_WINDOW_BORDER_WIDTH)----------------------------------------------------------------------------------- | (/freeglut only/) Contains the height of the header\/caption area of a--- window in pixels.--windowHeaderHeight :: GettableStateVar Int-windowHeaderHeight =-   makeGettableStateVar (simpleGet fromIntegral glut_WINDOW_HEADER_HEIGHT)----------------------------------------------------------------------------------- | (/freeglut on X11 only/) Controls if all but the last motion event should--- be discarded.--skipStaleMotionEvents :: StateVar Bool-skipStaleMotionEvents =-   makeStateVar-      (simpleGet i2b glut_SKIP_STALE_MOTION_EVENTS)-      (glutSetOption glut_SKIP_STALE_MOTION_EVENTS . b2i)----------------------------------------------------------------------------------- | (/freeglut only/) Contains 'True' if GLUT has been initialized --- with 'Graphics.UI.GLUT.Initialization.initialize' or--- 'Graphics.UI.GLUT.Initialization.getArgsAndInitialize' has and not yet--- been de-initialized with 'Graphics.UI.GLUT.Initialization.exit'. Contains--- 'False' otherwise.--initState :: GettableStateVar Bool-initState = makeGettableStateVar$ simpleGet i2b glut_INIT_STATE
− Graphics/UI/GLUT/Types.hs 
@@ -1,104 +0,0 @@-{-# OPTIONS_HADDOCK hide #-}------------------------------------------------------------------------------------ |--- Module      :  Graphics.UI.GLUT.Types--- Copyright   :  (c) Sven Panne 2002-2013--- License     :  BSD3------ Maintainer  :  Sven Panne <svenpanne@gmail.com>--- Stability   :  stable--- Portability :  portable------ This is a purely internal module with miscellaneous types which don\'t really--- have a good place elsewhere.--------------------------------------------------------------------------------------module Graphics.UI.GLUT.Types (-   Window(..),                               -- constructor used only internally-   Relation(..),-   relationToString,                         -- used only internally-   MouseButton(..),-   marshalMouseButton, unmarshalMouseButton  -- used only internally-) where--import Foreign.C.Types-import Graphics.UI.GLUT.Raw-------------------------------------------------------------------------------------- | An opaque identifier for a top-level window or a subwindow.--newtype Window = Window CInt-   deriving ( Eq, Ord, Show )-------------------------------------------------------------------------------------- | A relation between a 'Graphics.UI.GLUT.Initialization.DisplayCapability'--- and a numeric value.--data Relation-   = IsEqualTo        -- ^ Equal.-   | IsNotEqualTo     -- ^ Not equal.-   | IsLessThan       -- ^ Less than and preferring larger difference (the least-                      --   is best).-   | IsNotGreaterThan -- ^ Less than or equal and preferring larger difference-                      --   (the least is best).-   | IsGreaterThan    -- ^ Greater than and preferring larger differences (the-                      --   most is best).-   | IsAtLeast        -- ^ Greater than or equal and preferring more instead of-                      --   less. This relation is useful for allocating-                      --   resources like color precision or depth buffer-                      --   precision where the maximum precision is generally-                      --   preferred. Contrast with 'IsNotLessThan' relation.-   | IsNotLessThan    -- ^ Greater than or equal but preferring less instead of-                      --   more. This relation is useful for allocating-                      --   resources such as stencil bits or auxillary color-                      --   buffers where you would rather not over-allocate.-   deriving ( Eq, Ord, Show )--relationToString :: Relation -> String-relationToString IsEqualTo        = "="-relationToString IsNotEqualTo     = "!="-relationToString IsLessThan       = "<"-relationToString IsNotGreaterThan = "<="-relationToString IsGreaterThan    = ">"-relationToString IsAtLeast        = ">="-relationToString IsNotLessThan    = "~"-------------------------------------------------------------------------------------- | Mouse buttons, including a wheel--data MouseButton-   = LeftButton-   | MiddleButton-   | RightButton-   | WheelUp-   | WheelDown-   | AdditionalButton Int-   deriving ( Eq, Ord, Show )--marshalMouseButton :: MouseButton -> CInt-marshalMouseButton x = case x of-   LeftButton -> glut_LEFT_BUTTON-   MiddleButton -> glut_MIDDLE_BUTTON-   RightButton -> glut_RIGHT_BUTTON-   WheelUp -> glut_WHEEL_UP-   WheelDown -> glut_WHEEL_DOWN-   AdditionalButton b -> fromIntegral b--unmarshalMouseButton :: CInt -> MouseButton-unmarshalMouseButton x-   | x == glut_LEFT_BUTTON = LeftButton-   | x == glut_MIDDLE_BUTTON = MiddleButton-   | x == glut_RIGHT_BUTTON = RightButton-   | x == glut_WHEEL_UP = WheelUp-   | x == glut_WHEEL_DOWN = WheelDown-   | otherwise = AdditionalButton (fromIntegral x)--glut_WHEEL_UP :: CInt-glut_WHEEL_UP = 3--glut_WHEEL_DOWN :: CInt-glut_WHEEL_DOWN = 4
− Graphics/UI/GLUT/Window.hs 
@@ -1,502 +0,0 @@------------------------------------------------------------------------------------ |--- Module      :  Graphics.UI.GLUT.Window--- Copyright   :  (c) Sven Panne 2002-2013--- License     :  BSD3------ Maintainer  :  Sven Panne <svenpanne@gmail.com>--- Stability   :  stable--- Portability :  portable------ GLUT supports two types of windows: top-level windows and subwindows. Both--- types support OpenGL rendering and GLUT callbacks. There is a single--- identifier space for both types of windows.--------------------------------------------------------------------------------------module Graphics.UI.GLUT.Window (-   -- * Window identifiers-   Window,--   -- * Creating and destroying (sub-)windows--   -- $CreatingAndDestroyingSubWindows-   createWindow, createSubWindow, destroyWindow,-   parentWindow, numSubWindows,--   -- * Manipulating the /current window/-   currentWindow,--   -- * Re-displaying and double buffer management-   postRedisplay, swapBuffers,--   -- * Changing the window geometry--   -- $ChangingTheWindowGeometry-   windowPosition, windowSize, fullScreen, fullScreenToggle, leaveFullScreen,--   -- * Manipulating the stacking order--   -- $ManipulatingTheStackingOrder-   pushWindow, popWindow,--   -- * Managing a window\'s display status-   WindowStatus(..), windowStatus,--   -- * Changing the window\/icon title--   -- $ChangingTheWindowIconTitle-   windowTitle, iconTitle,--   -- * Cursor management-   Cursor(..), cursor, pointerPosition-) where--import Foreign.C.String-import Foreign.C.Types-import Graphics.Rendering.OpenGL ( Position(..), Size(..)-                                 , StateVar, makeStateVar-                                 , GettableStateVar, makeGettableStateVar-                                 , SettableStateVar, makeSettableStateVar )-import Graphics.UI.GLUT.QueryUtils-import Graphics.UI.GLUT.Raw-import Graphics.UI.GLUT.Types-------------------------------------------------------------------------------------- $CreatingAndDestroyingSubWindows--- Each created window has a unique associated OpenGL context. State changes to--- a window\'s associated OpenGL context can be done immediately after the--- window is created.------ The /display state/ of a window is initially for the window to be shown. But--- the window\'s /display state/ is not actually acted upon until--- 'Graphics.UI.GLUT.Begin.mainLoop' is entered. This means until--- 'Graphics.UI.GLUT.Begin.mainLoop' is called, rendering to a created window is--- ineffective because the window can not yet be displayed.------ The value returned by 'createWindow' and 'createSubWindow' is a unique--- identifier for the window, which can be used with 'currentWindow'.---- | Create a top-level window. The given name will be provided to the window--- system as the window\'s name. The intent is that the window system will label--- the window with the name.Implicitly, the /current window/ is set to the newly--- created window.------ /X Implementation Notes:/ The proper X Inter-Client Communication Conventions--- Manual (ICCCM) top-level properties are established. The @WM_COMMAND@--- property that lists the command line used to invoke the GLUT program is only--- established for the first window created.--createWindow-   :: String    -- ^ The window name-   -> IO Window -- ^ The identifier for the newly created window-createWindow name = fmap Window $ withCString name glutCreateWindow-------------------------------------------------------------------------------------- | Create a subwindow of the identified window with the given relative--- position and size. Implicitly, the /current window/ is set to the--- newly created subwindow. Subwindows can be nested arbitrarily deep.--createSubWindow-   :: Window    -- ^ Identifier of the subwindow\'s parent window.-   -> Position  -- ^ Window position in pixels relative to parent window\'s-                --   origin.-   -> Size      -- ^ Window size in pixels-   -> IO Window -- ^ The identifier for the newly created subwindow-createSubWindow (Window win) (Position x y) (Size w h) =-   fmap Window $-      glutCreateSubWindow win-                          (fromIntegral x) (fromIntegral y)-                          (fromIntegral w) (fromIntegral h)-------------------------------------------------------------------------------------- | Contains the /current window\'s/ parent. If the /current window/ is a--- top-level window, 'Nothing' is returned.--parentWindow :: GettableStateVar (Maybe Window)-parentWindow =-   makeGettableStateVar $-      getWindow (simpleGet Window glut_WINDOW_PARENT)-------------------------------------------------------------------------------------- | Contains the number of subwindows the /current window/ has, not counting--- children of children.--numSubWindows :: GettableStateVar Int-numSubWindows =-   makeGettableStateVar $-      simpleGet fromIntegral glut_WINDOW_NUM_CHILDREN-------------------------------------------------------------------------------------- | Destroy the specified window and the window\'s associated OpenGL context,--- logical colormap (if the window is color index), and overlay and related--- state (if an overlay has been established). Any subwindows of the destroyed--- window are also destroyed by 'destroyWindow'. If the specified window was the--- /current window/, the /current window/ becomes invalid ('currentWindow' will--- contain 'Nothing').--destroyWindow :: Window -> IO ()-destroyWindow (Window win) = glutDestroyWindow win-------------------------------------------------------------------------------------- | Controls the /current window/. It does /not/ affect the /layer in use/ for--- the window; this is done using 'Graphics.UI.GLUT.Overlay.layerInUse'.--- Contains 'Nothing' if no windows exist or the previously /current window/ was--- destroyed. Setting the /current window/ to 'Nothing' is a no-op.--currentWindow :: StateVar (Maybe Window)-currentWindow =-   makeStateVar-      (getWindow (fmap Window glutGetWindow))-      (maybe (return ()) (\(Window win) -> glutSetWindow win))--getWindow :: IO Window -> IO (Maybe Window)-getWindow act = do-   win <- act-   return $ if win == Window 0 then Nothing else Just win-------------------------------------------------------------------------------------- | Mark the normal plane of given window (or the /current window/, if none--- is supplied) as needing to be redisplayed. The next iteration through--- 'Graphics.UI.GLUT.Begin.mainLoop', the window\'s display callback will be--- called to redisplay the window\'s normal plane. Multiple calls to--- 'postRedisplay' before the next display callback opportunity generates only a--- single redisplay callback. 'postRedisplay' may be called within a window\'s--- display or overlay display callback to re-mark that window for redisplay.------ Logically, normal plane damage notification for a window is treated as a--- 'postRedisplay' on the damaged window. Unlike damage reported by the window--- system, 'postRedisplay' will /not/ set to true the normal plane\'s damaged--- status (see 'Graphics.UI.GLUT.State.damaged').------ Also, see 'Graphics.UI.GLUT.Overlay.postOverlayRedisplay'.--postRedisplay :: Maybe Window -> IO ()-postRedisplay = maybe glutPostRedisplay (\(Window win) -> glutPostWindowRedisplay win)---- | Mark the normal plane of the given window as needing to be redisplayed,--- otherwise the same as 'postRedisplay'.------ The advantage of this routine is that it saves the cost of using--- 'currentWindow' (entailing an expensive OpenGL context switch), which is--- particularly useful when multiple windows need redisplays posted at the same--- time.-------------------------------------------------------------------------------------- | Perform a buffer swap on the /layer in use/ for the /current window/.--- Specifically, 'swapBuffers' promotes the contents of the back buffer of the--- /layer in use/ of the /current window/ to become the contents of the front--- buffer. The contents of the back buffer then become undefined. The update--- typically takes place during the vertical retrace of the monitor, rather than--- immediately after 'swapBuffers' is called.------ An implicit 'Graphics.Rendering.OpenGL.GL.FlushFinish.flush' is done by--- 'swapBuffers' before it returns. Subsequent OpenGL commands can be issued--- immediately after calling 'swapBuffers', but are not executed until the--- buffer exchange is completed.------ If the /layer in use/ is not double buffered, 'swapBuffers' has no effect.--swapBuffers :: IO ()-swapBuffers = glutSwapBuffers-------------------------------------------------------------------------------------- $ChangingTheWindowGeometry--- Note that the requests by 'windowPosition', 'windowSize', and 'fullScreen'--- are not processed immediately. A request is executed after returning to the--- main event loop. This allows multiple requests to the same window to be--- coalesced.------ 'windowPosition' and 'windowSize' requests on a window will disable the full--- screen status of the window.-------------------------------------------------------------------------------------- | Controls the position of the /current window/. For top-level windows,--- parameters of 'Position' are pixel offsets from the screen origin. For--- subwindows, the parameters are pixel offsets from the window\'s parent window--- origin.------ In the case of top-level windows, setting 'windowPosition' is considered only--- a request for positioning the window. The window system is free to apply its--- own policies to top-level window placement. The intent is that top-level--- windows should be repositioned according to the value of 'windowPosition'.--windowPosition :: StateVar Position-windowPosition = makeStateVar getWindowPosition setWindowPosition--setWindowPosition :: Position -> IO ()-setWindowPosition (Position x y) =-   glutPositionWindow (fromIntegral x) (fromIntegral y)--getWindowPosition :: IO Position-getWindowPosition = do-   x <- simpleGet fromIntegral glut_WINDOW_X-   y <- simpleGet fromIntegral glut_WINDOW_Y-   return $ Position x y-------------------------------------------------------------------------------------- | Controls the size of the /current window/. The parameters of 'Size' are--- size extents in pixels. The width and height must be positive values.------ In the case of top-level windows, setting 'windowSize' is considered only a--- request for sizing the window. The window system is free to apply its own--- policies to top-level window sizing. The intent is that top-level windows--- should be reshaped according to the value of 'windowSize'. Whether a reshape--- actually takes effect and, if so, the reshaped dimensions are reported to the--- program by a reshape callback.--windowSize :: StateVar Size-windowSize = makeStateVar getWindowSize setWindowSize--setWindowSize :: Size -> IO ()-setWindowSize (Size w h) =-   glutReshapeWindow (fromIntegral w) (fromIntegral h)--getWindowSize :: IO Size-getWindowSize = do-   w <- simpleGet fromIntegral glut_WINDOW_WIDTH-   h <- simpleGet fromIntegral glut_WINDOW_HEIGHT-   return $ Size w h-------------------------------------------------------------------------------------- | Request that the /current window/ be made full screen. The exact semantics--- of what full screen means may vary by window system. The intent is to make--- the window as large as possible and disable any window decorations or borders--- added the window system. The window width and height are not guaranteed to be--- the same as the screen width and height, but that is the intent of making a--- window full screen.------ 'fullScreen' is defined to work only on top-level windows.------ /X Implementation Notes:/ In the X implementation of GLUT, full screen is--- implemented by sizing and positioning the window to cover the entire screen--- and posting the @_MOTIF_WM_HINTS@ property on the window requesting--- absolutely no decorations. Non-Motif window managers may not respond to--- @_MOTIF_WM_HINTS@.--fullScreen :: IO ()-fullScreen = glutFullScreen-------------------------------------------------------------------------------------- | (/freeglut only/) Toggle between windowed and full screen mode.--fullScreenToggle :: IO ()-fullScreenToggle = glutFullScreenToggle-------------------------------------------------------------------------------------- | (/freeglut only/) If we are in full screen mode, resize the current window--- back to its original size.--leaveFullScreen :: IO ()-leaveFullScreen = glutLeaveFullScreen-------------------------------------------------------------------------------------- $ManipulatingTheStackingOrder--- 'pushWindow' and 'popWindow' work on both top-level windows and subwindows.--- The effect of pushing and popping windows does not take place immediately.--- Instead the push or pop is saved for execution upon return to the GLUT event--- loop. Subsequent pop or push requests on a window replace the previously--- saved request for that window. The effect of pushing and popping top-level--- windows is subject to the window system\'s policy for restacking windows.---- | Change the stacking order of the /current window/ relative to its siblings--- (lowering it).--pushWindow :: IO ()-pushWindow = glutPushWindow---- | Change the stacking order of the /current window/ relative to its siblings,--- bringing the /current window/ closer to the top.--popWindow :: IO ()-popWindow = glutPopWindow-------------------------------------------------------------------------------------- | The display status of a window.--data WindowStatus-   = Shown-   | Hidden-   | Iconified-   deriving ( Eq, Ord, Show )---- | Controls the display status of the /current window/.------ Note that the effect of showing, hiding, and iconifying windows does not take--- place immediately. Instead the requests are saved for execution upon return--- to the GLUT event loop. Subsequent show, hide, or iconification requests on a--- window replace the previously saved request for that window. The effect of--- hiding, showing, or iconifying top-level windows is subject to the window--- system\'s policy for displaying windows. Subwindows can\'t be iconified.--windowStatus :: SettableStateVar WindowStatus-windowStatus = makeSettableStateVar setStatus-   where setStatus Shown     = glutShowWindow-         setStatus Hidden    = glutHideWindow-         setStatus Iconified = glutIconifyWindow-------------------------------------------------------------------------------------- $ChangingTheWindowIconTitle--- 'windowTitle' and 'iconTitle' should be set only when the /current--- window/ is a top-level window. Upon creation of a top-level window, the--- window and icon names are determined by the name given to 'createWindow'.--- Once created, setting 'windowTitle' and 'iconTitle' can change the window and--- icon names respectively of top-level windows. Each call requests the window--- system change the title appropriately. Requests are not buffered or--- coalesced. The policy by which the window and icon name are displayed is--- window system dependent.---- | Controls the window title of the /current top-level window/.--windowTitle :: SettableStateVar String-windowTitle =-   makeSettableStateVar $ \name ->-      withCString name glutSetWindowTitle---- | Controls the icon title of the /current top-level window/.--iconTitle :: SettableStateVar String-iconTitle =-   makeSettableStateVar $ \name ->-      withCString name glutSetIconTitle-------------------------------------------------------------------------------------- | The different cursor images GLUT supports.--data Cursor-   = RightArrow        -- ^ Arrow pointing up and to the right.-   | LeftArrow         -- ^ Arrow pointing up and to the left.-   | Info              -- ^ Pointing hand.-   | Destroy           -- ^ Skull & cross bones.-   | Help              -- ^ Question mark.-   | Cycle             -- ^ Arrows rotating in a circle.-   | Spray             -- ^ Spray can.-   | Wait              -- ^ Wrist watch.-   | Text              -- ^ Insertion point cursor for text.-   | Crosshair         -- ^ Simple cross-hair.-   | UpDown            -- ^ Bi-directional pointing up & down.-   | LeftRight         -- ^ Bi-directional pointing left & right.-   | TopSide           -- ^ Arrow pointing to top side.-   | BottomSide        -- ^ Arrow pointing to bottom side.-   | LeftSide          -- ^ Arrow pointing to left side.-   | RightSide         -- ^ Arrow pointing to right side.-   | TopLeftCorner     -- ^ Arrow pointing to top-left corner.-   | TopRightCorner    -- ^ Arrow pointing to top-right corner.-   | BottomRightCorner -- ^ Arrow pointing to bottom-left corner.-   | BottomLeftCorner  -- ^ Arrow pointing to bottom-right corner.-   | Inherit           -- ^ Use parent\'s cursor.-   | None              -- ^ Invisible cursor.-   | FullCrosshair     -- ^ Full-screen cross-hair cursor (if possible, otherwise 'Crosshair').-   deriving ( Eq, Ord, Show )--marshalCursor :: Cursor -> CInt-marshalCursor x = case x of-   RightArrow -> glut_CURSOR_RIGHT_ARROW-   LeftArrow -> glut_CURSOR_LEFT_ARROW-   Info -> glut_CURSOR_INFO-   Destroy -> glut_CURSOR_DESTROY-   Help -> glut_CURSOR_HELP-   Cycle -> glut_CURSOR_CYCLE-   Spray -> glut_CURSOR_SPRAY-   Wait -> glut_CURSOR_WAIT-   Text -> glut_CURSOR_TEXT-   Crosshair -> glut_CURSOR_CROSSHAIR-   UpDown -> glut_CURSOR_UP_DOWN-   LeftRight -> glut_CURSOR_LEFT_RIGHT-   TopSide -> glut_CURSOR_TOP_SIDE-   BottomSide -> glut_CURSOR_BOTTOM_SIDE-   LeftSide -> glut_CURSOR_LEFT_SIDE-   RightSide -> glut_CURSOR_RIGHT_SIDE-   TopLeftCorner -> glut_CURSOR_TOP_LEFT_CORNER-   TopRightCorner -> glut_CURSOR_TOP_RIGHT_CORNER-   BottomRightCorner -> glut_CURSOR_BOTTOM_RIGHT_CORNER-   BottomLeftCorner -> glut_CURSOR_BOTTOM_LEFT_CORNER-   Inherit -> glut_CURSOR_INHERIT-   None -> glut_CURSOR_NONE-   FullCrosshair -> glut_CURSOR_FULL_CROSSHAIR--unmarshalCursor :: CInt -> Cursor-unmarshalCursor x-   | x == glut_CURSOR_RIGHT_ARROW = RightArrow-   | x == glut_CURSOR_LEFT_ARROW = LeftArrow-   | x == glut_CURSOR_INFO = Info-   | x == glut_CURSOR_DESTROY = Destroy-   | x == glut_CURSOR_HELP = Help-   | x == glut_CURSOR_CYCLE = Cycle-   | x == glut_CURSOR_SPRAY = Spray-   | x == glut_CURSOR_WAIT = Wait-   | x == glut_CURSOR_TEXT = Text-   | x == glut_CURSOR_CROSSHAIR = Crosshair-   | x == glut_CURSOR_UP_DOWN = UpDown-   | x == glut_CURSOR_LEFT_RIGHT = LeftRight-   | x == glut_CURSOR_TOP_SIDE = TopSide-   | x == glut_CURSOR_BOTTOM_SIDE = BottomSide-   | x == glut_CURSOR_LEFT_SIDE = LeftSide-   | x == glut_CURSOR_RIGHT_SIDE = RightSide-   | x == glut_CURSOR_TOP_LEFT_CORNER = TopLeftCorner-   | x == glut_CURSOR_TOP_RIGHT_CORNER = TopRightCorner-   | x == glut_CURSOR_BOTTOM_RIGHT_CORNER = BottomRightCorner-   | x == glut_CURSOR_BOTTOM_LEFT_CORNER = BottomLeftCorner-   | x == glut_CURSOR_INHERIT = Inherit-   | x == glut_CURSOR_NONE = None-   | x == glut_CURSOR_FULL_CROSSHAIR = FullCrosshair-   | otherwise = error ("unmarshalCursor: illegal value " ++ show x)-------------------------------------------------------------------------------------- | Change the cursor image of the /current window/. Each call requests the--- window system change the cursor appropriately. The cursor image when a window--- is created is 'Inherit'. The exact cursor images used are implementation--- dependent. The intent is for the image to convey the meaning of the cursor--- name. For a top-level window, 'Inherit' uses the default window system--- cursor.------ /X Implementation Notes:/ GLUT for X uses SGI\'s @_SGI_CROSSHAIR_CURSOR@--- convention to access a full-screen cross-hair cursor if possible.--cursor :: StateVar Cursor-cursor = makeStateVar getCursor setCursor--setCursor :: Cursor -> IO ()-setCursor = glutSetCursor . marshalCursor--getCursor :: IO Cursor-getCursor = simpleGet unmarshalCursor glut_WINDOW_CURSOR-------------------------------------------------------------------------------------- | Setting 'pointerPosition' warps the window system\'s pointer to a new--- location relative to the origin of the /current window/ by the specified--- pixel offset, which may be negative. The warp is done immediately.------ If the pointer would be warped outside the screen\'s frame buffer region, the--- location will be clamped to the nearest screen edge. The window system is--- allowed to further constrain the pointer\'s location in window system--- dependent ways.------ Good advice from Xlib\'s @XWarpPointer@ man page: \"There is seldom any--- reason for calling this function. The pointer should normally be left to the--- user.\"--pointerPosition :: SettableStateVar Position-pointerPosition =-   makeSettableStateVar $ \(Position x y) ->-      glutWarpPointer (fromIntegral x) (fromIntegral y)
README.md view
@@ -1,1 +1,1 @@-[![Build Status](https://travis-ci.org/haskell-opengl/GLUT.png)](https://travis-ci.org/haskell-opengl/GLUT)+[![Hackage](https://img.shields.io/hackage/v/GLUT.svg)](https://hackage.haskell.org/package/GLUT) [![Build Status](https://travis-ci.org/haskell-opengl/GLUT.png)](https://travis-ci.org/haskell-opengl/GLUT)
examples/BOGLGP/Chapter03/TrianglesQuads.hs view
@@ -252,7 +252,7 @@    renderPrimitive TriangleFan $ do       -- center vertex of fan       vertex (Vertex3 0 0 (0 :: GLfloat))-	+       -- bottom side       for [ 3, 2 .. 0 ] $ \x ->          vertex (Vertex3 x 0 3)
examples/Misc/ColorTriangle/color_triangles.frac view
@@ -1,6 +1,6 @@ #version 430 core -in vec4 color;	+in vec4 color; out vec4 fColor;  void
examples/OrangeBook/ogl2brick/Brick.hs view
@@ -8,7 +8,7 @@ import Prelude hiding ( sum ) import Control.Applicative import Control.Exception ( IOException, catch )-import Control.Monad+import Control.Monad ( when, unless ) import qualified Data.ByteString as B import Data.Foldable ( Foldable, sum ) import Data.IORef
examples/RedBook4/AccPersp.hs view
@@ -40,13 +40,13 @@ accFrustum left right bottom top zNear zFar            (Vector2 pixDx pixDy) (Vector2 eyeDx eyeDy) focus = do    (_, Size w h) <- get viewport-	+    let xWSize = right - left;        yWSize = top - bottom;-	+        dx = -(pixDx * xWSize / fromIntegral w + eyeDx * zNear / focus)        dy = -(pixDy * yWSize / fromIntegral h + eyeDy * zNear / focus)-	+    matrixMode $= Projection    loadIdentity    frustum (left + dx) (right + dx) (bottom + dy) (top + dy) zNear zFar
examples/RedBook4/DOF.hs view
@@ -42,13 +42,13 @@ accFrustum left right bottom top zNear zFar            (Vector2 pixDx pixDy) (Vector2 eyeDx eyeDy) focus = do    (_, Size w h) <- get viewport-	+    let xWSize = right - left;        yWSize = top - bottom;-	+        dx = -(pixDx * xWSize / fromIntegral w + eyeDx * zNear / focus)        dy = -(pixDy * yWSize / fromIntegral h + eyeDy * zNear / focus)-	+    matrixMode $= Projection    loadIdentity    frustum (left + dx) (right + dx) (bottom + dy) (top + dy) zNear zFar
+ src/Graphics/UI/GLUT.hs view
@@ -0,0 +1,386 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT+-- Copyright   :  (c) Sven Panne 2002-2013+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- Stability   :  stable+-- Portability :  portable+--+-- A Haskell binding for GLUT, the OpenGL Utility Toolkit, a window system+-- independent toolkit for writing OpenGL programs. It includes support for+-- the extended functionality available in freeglut (see+-- <http://freeglut.sourceforge.net/>) and OpenGLUT (see+-- <http://openglut.sourceforge.net/>), too.+--+-----------------------------------------------------------------------------++module Graphics.UI.GLUT (+   -- * Legal stuff++   -- $LegalStuff++   -- * Introduction++   -- $Introduction++   -- ** Background++   -- $Background++   -- ** Design Philosophy++   -- $DesignPhilosophy++   -- ** API Versions++   -- $APIVersions++   -- ** Conventions++   -- $Conventions++   -- ** Terminology++   -- $Terminology++   module Graphics.Rendering.OpenGL,++   module Graphics.UI.GLUT.Initialization,+   module Graphics.UI.GLUT.Begin,+   module Graphics.UI.GLUT.Window,+   module Graphics.UI.GLUT.Overlay,+   module Graphics.UI.GLUT.Menu,+   module Graphics.UI.GLUT.Callbacks,+   module Graphics.UI.GLUT.Colormap,+   module Graphics.UI.GLUT.State,+   module Graphics.UI.GLUT.Fonts,+   module Graphics.UI.GLUT.Objects,+   module Graphics.UI.GLUT.Debugging,+   module Graphics.UI.GLUT.DeviceControl,+   module Graphics.UI.GLUT.GameMode+)  where++import Graphics.Rendering.OpenGL++import Graphics.UI.GLUT.Initialization+import Graphics.UI.GLUT.Begin+import Graphics.UI.GLUT.Window+import Graphics.UI.GLUT.Overlay+import Graphics.UI.GLUT.Menu+import Graphics.UI.GLUT.Callbacks+import Graphics.UI.GLUT.Colormap+import Graphics.UI.GLUT.State+import Graphics.UI.GLUT.Fonts+import Graphics.UI.GLUT.Objects+import Graphics.UI.GLUT.Debugging+import Graphics.UI.GLUT.DeviceControl+import Graphics.UI.GLUT.GameMode++-----------------------------------------------------------------------------+-- $LegalStuff+-- This documentation is heavily based on the man pages of Mark J. Kilgard\'s+-- GLUT library.+--+-- OpenGL is a trademark of Silicon Graphics, Inc.+-- X Window System is a trademark of X Consortium, Inc.+-- Spaceball is a registered trademark of Spatial Systems, Inc.+--+-- The author has taken care in preparation of this documentation but makes+-- no expressed or implied warranty of any kind and assumes no responsibility+-- for errors or omissions. No liability is assumed for incidental or+-- consequential damages in connection with or arising from the use of+-- information or programs contained herein.++-----------------------------------------------------------------------------+-- $Introduction+-- The OpenGL Utility Toolkit (GLUT) is a programming interface for writing+-- window system independent OpenGL programs. Currently there are+-- implementations for the X Window System, the Windows family, OS\/2, and Mac.+-- The toolkit supports the following functionality:+--+-- * Multiple windows for OpenGL rendering.+--+-- * Callback driven event processing.+--+-- * Sophisticated input devices.+--+-- * An /idle/ routine and timers.+--+-- * A simple, cascading pop-up menu facility.+--+-- * Utility routines to generate various solid and wire frame objects.+--+-- * Support for bitmap and stroke fonts.+--+-- * Miscellaneous window management functions, including managing overlays.+--+-- This documentation serves as both a specification and a programming guide.+-- If you are interested in a brief introduction to programming with GLUT,+-- have a look at the relevant parts of <http://www.opengl.org/> and the vast+-- amount of books on OpenGL, most of them use GLUT.+--+-- The remainder of this section describes GLUT\'s design philosophy and+-- usage model. The following sections specify the GLUT routines, grouped by+-- functionality. The final sections discuss usage advice and the logical+-- programmer visible state maintained by GLUT.++-----------------------------------------------------------------------------+-- $Background+-- One of the major accomplishments in the specification of OpenGL was+-- the isolation of window system dependencies from OpenGL\'s rendering+-- model. The result is that OpenGL is window system independent.+--+-- Window system operations such as the creation of a rendering window and the+-- handling of window system events are left to the native window system to+-- define. Necessary interactions between OpenGL and the window system such as+-- creating and binding an OpenGL context to a window are described separately+-- from the OpenGL specification in a window system dependent specification. For+-- example, the GLX specification describes the standard by which OpenGL+-- interacts with the X Window System.+--+-- The predecessor to OpenGL is IRIS GL. Unlike OpenGL, IRIS GL /does/+-- specify how rendering windows are created and manipulated. IRIS GL\'s+-- windowing interface is reasonably popular largely because it is simple to+-- use. IRIS GL programmers can worry about graphics programming without needing+-- to be an expert in programming the native window system. Experience also+-- demonstrated that IRIS GL\'s windowing interface was high-level enough that+-- it could be retargeted to different window systems. Silicon Graphics migrated+-- from NeWS to the X Window System without any major changes to IRIS GL\'s+-- basic windowing interface.+--+-- Removing window system operations from OpenGL is a sound decision because it+-- allows the OpenGL graphics system to be retargeted to various systems+-- including powerful but expensive graphics workstations as well as+-- mass-production graphics systems like video games, set-top boxes for+-- interactive television, and PCs.+--+-- Unfortunately, the lack of a window system interface for OpenGL is a gap in+-- OpenGL\'s utility. Learning native window system APIs such as the X Window+-- System\'s Xlib or Motif can be daunting. Even those familiar with+-- native window system APIs need to understand the interface that binds OpenGL+-- to the native window system. And when an OpenGL program is written using the+-- native window system interface, despite the portability of the program\'s+-- OpenGL rendering code, the program itself will be window system dependent.+--+-- Testing and documenting OpenGL\'s functionality lead to the development of+-- the @tk@ and @aux@ toolkits. The @aux@ toolkit is used in the examples found+-- in the /OpenGL Programming Guide/. Unfortunately, @aux@ has numerous+-- limitations and its utility is largely limited to toy programs. The @tk@+-- library has more functionality than @aux@ but was developed in an /ad hoc/+-- fashion and still lacks much important functionality that IRIS GL programmers+-- expect, like pop-up menus and overlays.+--+-- GLUT is designed to fill the need for a window system independent programming+-- interface for OpenGL programs. The interface is designed to be simple yet+-- still meet the needs of useful OpenGL programs. Features from the IRIS GL,+-- @aux@, and @tk@ interfaces are included to make it easy for programmers used+-- to these interfaces to develop programs for GLUT.++-----------------------------------------------------------------------------+-- $DesignPhilosophy+-- GLUT simplifies the implementation of programs using OpenGL rendering. The+-- GLUT application programming interface (API) requires very few routines to+-- display a graphics scene rendered using OpenGL. The GLUT API (like the OpenGL+-- API) is stateful. Most initial GLUT state is defined and the initial state is+-- reasonable for simple programs. The GLUT routines also take relatively few+-- parameters.+--+-- The GLUT API is (as much as reasonable) window system independent. For this+-- reason, GLUT does not return /any/ native window system handles, pointers, or+-- other data structures. More subtle window system dependencies such as+-- reliance on window system dependent fonts are avoided by GLUT; instead, GLUT+-- supplies its own (limited) set of fonts.+--+-- For programming ease, GLUT provides a simple menu sub-API. While the menuing+-- support is designed to be implemented as pop-up menus, GLUT gives window+-- system leeway to support the menu functionality in another manner (pull-down+-- menus for example).+--+-- Two of the most important pieces of GLUT state are the /current window/ and+-- /current menu/. Most window and menu routines affect the /current window/ or+-- /menu/ respectively. Most callbacks implicitly set the /current window/ and+-- /menu/ to the appropriate window or menu responsible for the callback. GLUT+-- is designed so that a program with only a single window and\/or menu will not+-- need to keep track of any window or menu identifiers. This greatly simplifies+-- very simple GLUT programs.+--+-- GLUT is designed for simple to moderately complex programs focused on OpenGL+-- rendering. GLUT implements its own event loop. For this reason, mixing GLUT+-- with other APIs that demand their own event handling structure may be+-- difficult. The advantage of a builtin event dispatch loop is simplicity.+--+-- GLUT contains routines for rendering fonts and geometric objects, however+-- GLUT makes no claims on the OpenGL display list name space. For this reason,+-- none of the GLUT rendering routines use OpenGL display lists. It is up to the+-- GLUT programmer to compile the output from GLUT rendering routines into+-- display lists if this is desired.+--+-- GLUT routines are logically organized into several sub-APIs according to+-- their functionality. The sub-APIs are:+--+-- * /Initialization:/ Command line processing, window system initialization,+--   and initial window creation state are controlled by these routines.+--+-- * /Beginning Event Processing:/ This routine enters GLUT\'s event processing+--   loop. This routine never returns, and it continuously calls GLUT callbacks+--   as necessary.+--+-- * /Window Management:/ These routines create and control windows.+--+-- * /Overlay Management:/ These routines establish and manage overlays for+--   windows.+--+-- * /Menu Management:/ These routines create and control pop-up menus.+--+-- * /Callback Registration:/ These routines register callbacks to be called by+--   the GLUT event processing loop.+--+-- * /Color Index Colormap Management:/ These routines allow the manipulation+--   of color index colormaps for windows.+--+-- * /State Retrieval:/ These routines allows programs to retrieve state from+--   GLUT.+--+-- * /Font Rendering:/ These routines allow rendering of stroke and bitmap+--   fonts.+--+-- * /Geometric Shape Rendering:/ These routines allow the rendering of 3D+--   geometric objects including spheres, cones, icosahedrons, and teapots.+--+-- * /Debugging:/ This routine reports any pending GL errors.+--+-- * /Device Control:/ These routines allow setting the key repeat and polling+--   the joystick.+--+-- * /Game Mode:/ These routines allow programs to enter\/leave a full-screen+--   mode with specified properties.++-- Note that the following item has been left out intentionally, its+-- implementation is too SGI-specific:+-- * /Video Resizing:/ These routines provide a means for doing swap or frame+--   synchronous resizing\/panning of the area that is to be magnified (or+--   passed through) to the output video resolution.++-----------------------------------------------------------------------------+-- $APIVersions+-- The GLUT API has undergone several revisions with increasing functionality.+-- This Haskell binding provides access to everything in API version 4,+-- although it is not yet officially finalized. Nevertheless, it provides very+-- useful things like handling full-screen modes and special keys.++-----------------------------------------------------------------------------+-- $Conventions+-- GLUT window and screen coordinates are expressed in pixels. The upper+-- left hand corner of the screen or a window is (0,0). X coordinates+-- increase in a rightward direction; Y coordinates increase in a+-- downward direction. Note: This is inconsistent with OpenGL\'s+-- coordinate scheme that generally considers the lower left hand+-- coordinate of a window to be at (0,0) but is consistent with most+-- popular window systems.++-----------------------------------------------------------------------------+-- $Terminology+-- A number of terms are used in a GLUT-specific manner throughout this+-- document. The GLUT meaning of these terms is independent of the window+-- system GLUT is used with. Here are GLUT-specific meanings for the+-- following GLUT-specific terms:+--+-- * /Callback:/ A programmer specified routine that can be registered with+--   GLUT to be called in response to a specific type of event. Also used to+-- refer to a specific callback routine being called.+--+-- * /Colormap:/ A mapping of pixel values to RGB color values. Used by color+--   index windows.+--+-- * /Dials and button box:/ A sophisticated input device consisting of a pad+--   of buttons and an array of rotating dials, often used by computer-aided+--   design programs.+--+-- * /Display mode:/ A set of OpenGL frame buffer capabilities that can be+--   attributed to a window.+--+-- * /Idle:/ A state when no window system events are received for processing+--   as callbacks and the idle callback, if one is registered, is called.+--+-- * /Layer in use:/ Either the normal plane or overlay. This per-window state+--   determines what frame buffer layer OpenGL commands affect.+--+-- * /Menu entry:/ A menu item that the user can select to trigger the menu+--   callback for the menu entry\'s value.+--+-- * /Menu item:/ Either a menu entry or a sub-menu trigger.+--+-- * /Modifiers:/ The Shift, Ctrl, and Alt keys that can be held down+--   simultaneously with a key or mouse button being pressed or released.+--+-- * /Multisampling:/ A technique for hardware antialiasing generally available+--   only on expensive 3D graphics hardware. Each pixel is composed of a number+--   of samples (each containing color and depth information). The samples are+--   averaged to determine the displayed pixel color value. Multisampling is+--   supported as an extension to OpenGL.+--+-- * /Normal plane:/ The default frame buffer layer where GLUT window state+--   resides; as opposed to the /overlay/.+--+-- * /Overlay:/ A frame buffer layer that can be displayed preferentially to+--   the /normal plane/ and supports transparency to display through to the+--   /normal plane/. Overlays are useful for rubber-banding effects, text+--   annotation, and other operations, to avoid damaging the normal plane frame+--   buffer state. Overlays require hardware support not present on all systems.+--+-- * /Pop:/ The act of forcing a window to the top of the stacking order for+--   sibling windows.+--+-- * /Pop-up menu:/ A menu that can be set to appear when a specified mouse+--   button is pressed in a window. A pop-menu consists of multiple menu items.+--+-- * /Push:/ The act of forcing a window to the bottom of the stacking order+--   for sibling windows.+--+-- * /Reshape:/ The act of changing the size or shape of the window.+--+-- * /Spaceball:/ A sophisticated 3D input device that provides six degrees of+--   freedom, three axes of rotation and three axes of translation. It also+--   supports a number of buttons. The device is a hand-sized ball attached to+--   a base. By cupping the ball with one\'s hand and applying torsional or+--   directional force on the ball, rotations and translationsare generated.+--+-- * /Stereo:/ A frame buffer capability providing left and right color buffers+--   for creating stereoscopic renderings. Typically, the user wears LCD+--   shuttered goggles synchronized with the alternating display on the screen+--   of the left and right color buffers.+--+-- * /Sub-menu:/ A menu cascaded from some sub-menu trigger.+--+-- * /Sub-menu trigger:/ A menu item that the user can enter to cascade another+--   pop-up menu.+--+-- * /Subwindow:/ A type of window that is the child window of a top-level+--   window or other subwindow. The drawing and visible region of a subwindow+--   is limited by its parent window.+--+-- * /Tablet:/ A precise 2D input device. Like a mouse, 2D coordinates are+--   returned. The absolute position of the tablet \"puck\" on the tablet is+--   returned. Tablets also support a number of buttons.+--+-- * /Timer:/ A callback that can be scheduled to be called in a specified+--   interval of time.+--+-- * /Top-level window:/ A window that can be placed, moved, resized, etc.+--   independently from other top-level windows by the user. Subwindows may+--   reside within a top-level window.+--+-- * /Window:/ A rectangular area for OpenGL rendering.+--+-- * /Window display state:/ One of shown, hidden, or iconified. A shown window+--   is potentially visible on the screen (it may be obscured by other windows+--   and not actually visible). A hidden window will never be visible. An+--   iconified window is not visible but could be made visible in response to+--   some user action like clicking on the window\'s corresponding icon.+--+-- * /Window system:/ A broad notion that refers to both the mechanism and+--   policy of the window system. For example, in the X Window System both the+--   window manager and the X server are integral to what GLUT considers the+--   window system.
+ src/Graphics/UI/GLUT/Begin.hs view
@@ -0,0 +1,98 @@+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Begin+-- Copyright   :  (c) Sven Panne 2002-2013+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- Stability   :  stable+-- Portability :  portable+--+-- After a GLUT program has done initial setup such as creating windows and+-- menus, GLUT programs enter the GLUT event processing loop by calling+-- 'mainLoop' or handle events iteratively with 'mainLoopEvent'.+--+--------------------------------------------------------------------------------++module Graphics.UI.GLUT.Begin (+   -- * Handling events+   mainLoop, mainLoopEvent, leaveMainLoop,++   -- * Controlling the behaviour when windows are closed+   ActionOnWindowClose(..), actionOnWindowClose+) where++import Foreign.C.Types+import Graphics.Rendering.OpenGL.GL.StateVar+import Graphics.UI.GLUT.QueryUtils+import Graphics.UI.GLUT.Raw++--------------------------------------------------------------------------------++-- | Enter the GLUT event processing loop; it will call as necessary any+-- callbacks that have been registered. This routine should be called at most+-- once in a GLUT program.++mainLoop :: IO ()+mainLoop = glutMainLoop++--------------------------------------------------------------------------------++-- | (/freeglut only/) Process one iteration's worth of events in its event loop.+-- This allows the application to control its own event loop and still use the+-- GLUT package.++mainLoopEvent :: IO ()+mainLoopEvent = glutMainLoopEvent++--------------------------------------------------------------------------------++-- | (/freeglut only/) Stop the event loop. If 'actionOnWindowClose' contains+-- 'Exit', the application will exit; otherwise control will return to the+-- function which called 'mainLoop'.+--+-- If the application has two nested calls to 'mainLoop' and calls+-- 'leaveMainLoop', the behaviour is undefined. It may leave only the inner+-- nested loop or it may leave both loops. If the reader has a strong preference+-- for one behaviour over the other he should contact the freeglut Programming+-- Consortium and ask for the code to be fixed.++leaveMainLoop :: IO ()+leaveMainLoop = glutLeaveMainLoop++--------------------------------------------------------------------------------++-- | The behaviour when the user closes a window.++data ActionOnWindowClose+   = -- | Exit the whole program when any window is closed or 'leaveMainLoop'+     -- is called (default).+     Exit+   | -- | Return from mainLoop when any window is closed.+     MainLoopReturns+   | -- | Return from mainLoop after the last window is closed.+     ContinueExecution+   deriving ( Eq, Ord, Show )++marshalActionOnWindowClose :: ActionOnWindowClose -> CInt+marshalActionOnWindowClose x = case x of+   Exit ->  glut_ACTION_EXIT+   MainLoopReturns -> glut_ACTION_GLUTMAINLOOP_RETURNS+   ContinueExecution -> glut_ACTION_CONTINUE_EXECUTION++unmarshalActionOnWindowClose :: CInt -> ActionOnWindowClose+unmarshalActionOnWindowClose x+   | x == glut_ACTION_EXIT = Exit+   | x == glut_ACTION_GLUTMAINLOOP_RETURNS = MainLoopReturns+   | x == glut_ACTION_CONTINUE_EXECUTION = ContinueExecution+   | otherwise = error ("unmarshalActionOnWindowClose: illegal value " ++ show x)++-----------------------------------------------------------------------------++-- | (/freeglut only/) Controls the behaviour when the user closes a window.++actionOnWindowClose :: StateVar ActionOnWindowClose+actionOnWindowClose =+   makeStateVar+      (simpleGet unmarshalActionOnWindowClose glut_ACTION_ON_WINDOW_CLOSE)+      (glutSetOption glut_ACTION_ON_WINDOW_CLOSE . marshalActionOnWindowClose)
+ src/Graphics/UI/GLUT/Callbacks.hs view
@@ -0,0 +1,47 @@+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Callbacks+-- Copyright   :  (c) Sven Panne 2002-2013+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- Stability   :  stable+-- Portability :  portable+--+--+-- GLUT supports a number of callbacks to respond to events. There are three+-- types of callbacks: window, menu, and global. Window callbacks indicate when+-- to redisplay or reshape a window, when the visibility of the window changes,+-- and when input is available for the window. Menu callbacks are described in+-- "Graphics.UI.GLUT.Menu". The global callbacks manage the passing of time and+-- menu usage. The calling order of callbacks between different windows is+-- undefined.+--+-- Callbacks for input events should be delivered to the window the event occurs+-- in. Events should not propagate to parent windows.+--+-- A callback of type @Foo@ can registered by setting @fooCallback@ to 'Just'+-- the callback. Almost all callbacks can be de-registered by setting+-- the corresponding @fooCallback@ to 'Nothing', the only exceptions being+-- 'Graphics.UI.GLUT.Callbacks.Window.DisplayCallback' (can only be+-- re-registered) and 'Graphics.UI.GLUT.Callbacks.Global.TimerCallback' (can\'t+-- be unregistered).+--+-- /X Implementation Notes:/ The X GLUT implementation uses the X Input+-- extension to support sophisticated input devices: Spaceball, dial & button+-- box, and digitizing tablet. Because the X Input extension  does not mandate+-- how particular types of devices are advertised through the extension, it is+-- possible GLUT for X may not correctly support input devices that would+-- otherwise be of the correct type. The X GLUT implementation will support the+-- Silicon Graphics Spaceball, dial & button box, and digitizing tablet as+-- advertised through the X Input extension.+--+--------------------------------------------------------------------------------++module Graphics.UI.GLUT.Callbacks (+   module Graphics.UI.GLUT.Callbacks.Window,+   module Graphics.UI.GLUT.Callbacks.Global+) where++import Graphics.UI.GLUT.Callbacks.Window+import Graphics.UI.GLUT.Callbacks.Global
+ src/Graphics/UI/GLUT/Callbacks/Global.hs view
@@ -0,0 +1,114 @@+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Callbacks.Global+-- Copyright   :  (c) Sven Panne 2002-2013+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- Stability   :  stable+-- Portability :  portable+--+--------------------------------------------------------------------------------++module Graphics.UI.GLUT.Callbacks.Global (+   -- * Menu status callback+   MenuUsage(..), MenuStatusCallback, menuStatusCallback,++   -- * Idle callback+   IdleCallback, idleCallback,++   -- * Timer callbacks+   Timeout, TimerCallback, addTimerCallback+) where++import Control.Monad.Fix+import Foreign.C.Types+import Graphics.Rendering.OpenGL ( Position(..)+                                 , SettableStateVar+                                 , makeSettableStateVar )+import Graphics.UI.GLUT.Callbacks.Registration+import Graphics.UI.GLUT.Raw++--------------------------------------------------------------------------------++data MenuUsage+   = NotInUse+   | InUse+   deriving ( Eq, Ord, Show )++unmarshalMenuUsage :: CInt -> MenuUsage+unmarshalMenuUsage x+   | x == glut_MENU_NOT_IN_USE = NotInUse+   | x == glut_MENU_IN_USE = InUse+   | otherwise = error ("unmarshalMenuUsage: illegal value " ++ show x)++type MenuStatusCallback  = MenuUsage -> Position -> IO ()++-- | Controls the global menu status callback so a GLUT program can determine+-- when a menu is in use or not. When a menu status callback is registered, it+-- will be called with the value 'InUse' when pop-up menus are in use by the+-- user; and the callback will be called with the value 'NotInUse' when pop-up+-- menus are no longer in use. Additionally, the location in window coordinates+-- of the button press that caused the menu to go into use, or the location where+-- the menu was released (maybe outside the window). Other callbacks continue to+-- operate (except mouse motion callbacks) when pop-up menus are in use so the+-- menu status callback allows a program to suspend animation or other tasks+-- when menus are in use. The cascading and unmapping of sub-menus from an+-- initial pop-up menu does not generate menu status callbacks. There is a+-- single menu status callback for GLUT.+--+-- When the menu status callback is called, the /current menu/ will be set to+-- the initial pop-up menu in both the 'InUse' and 'NotInUse' cases. The+-- /current window/ will be set to the window from which the initial menu was+-- popped up from, also in both cases.++menuStatusCallback :: SettableStateVar (Maybe MenuStatusCallback)+menuStatusCallback =+   makeSettableStateVar $+      setCallback MenuStatusCB glutMenuStatusFunc+                  (makeMenuStatusFunc . unmarshal)+   where unmarshal cb s x y =+            cb (unmarshalMenuUsage s)+               (Position (fromIntegral x) (fromIntegral y))++--------------------------------------------------------------------------------++type IdleCallback = IO ()++-- | Controls the global idle callback so a GLUT program can perform background+-- processing tasks or continuous animation when window system events are not+-- being received. If enabled, the idle callback is continuously called when+-- events are not being received. The /current window/ and /current menu/ will+-- not be changed before the idle callback. Programs with multiple windows+-- and\/or menus should explicitly set the /current window/ and\/or /current+-- menu/ and not rely on its current setting.+--+-- The amount of computation and rendering done in an idle callback should be+-- minimized to avoid affecting the program\'s interactive response. In general,+-- not more than a single frame of rendering should be done in an idle callback.++idleCallback :: SettableStateVar (Maybe IdleCallback)+idleCallback =+   makeSettableStateVar $ setCallback IdleCB glutIdleFunc makeIdleFunc++--------------------------------------------------------------------------------++-- | Timeout for the timer callback in milliseconds+type Timeout = Int++type TimerCallback  = IO ()++-- | Register a one-shot timer callback to be triggered after at least the given+-- amount of time. Multiple timer callbacks at same or differing times may be+-- registered simultaneously. There is no support for canceling a registered+-- callback.+--+-- The number of milliseconds is a lower bound on the time before the callback+-- is generated. GLUT attempts to deliver the timer callback as soon as possible+-- after the expiration of the callback\'s time interval.++addTimerCallback :: Timeout -> TimerCallback -> IO ()+addTimerCallback msecs timerCallback = do+   funPtr <- mfix (\self -> makeTimerFunc (\_ -> do registerForCleanup self+                                                    timerCallback))+   glutTimerFunc (fromIntegral msecs) funPtr 0
+ src/Graphics/UI/GLUT/Callbacks/Registration.hs view
@@ -0,0 +1,162 @@+{-# OPTIONS_GHC -fno-cse #-}++{-# OPTIONS_HADDOCK hide #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Callbacks.Registration+-- Copyright   :  (c) Sven Panne 2002-2013+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- Stability   :  stable+-- Portability :  portable+--+--------------------------------------------------------------------------------++module Graphics.UI.GLUT.Callbacks.Registration (+   CallbackType(..), registerForCleanup, setCallback, getCurrentWindow+) where++--------------------------------------------------------------------------------++import Control.Monad+import Data.IORef+import qualified Data.Map as Map ( empty, lookup, insert, delete )+import Data.Map ( Map )+import Foreign.Ptr+import Graphics.Rendering.OpenGL ( get )+import Graphics.UI.GLUT.Raw+import Graphics.UI.GLUT.Window++--------------------------------------------------------------------------------+-- No timer callback here, because they are one-shot and "self destroy"++data CallbackType+   = DisplayCB         | OverlayDisplayCB  | ReshapeCB+   | KeyboardCB        | KeyboardUpCB      | MouseCB+   | MotionCB          | PassiveMotionCB   | CrossingCB+   | VisibilityCB      | WindowStatusCB    | SpecialCB+   | SpecialUpCB       | SpaceballMotionCB | SpaceballRotateCB+   | SpaceballButtonCB | ButtonBoxCB       | DialsCB+   | TabletMotionCB    | TabletButtonCB    | JoystickCB+   | MenuStatusCB      | IdleCB+   -- freeglut-only callback types+   | CloseCB           | MouseWheelCB      | PositionCB+   | MultiEntryCB      | MultiMotionCB     | MultiButtonCB+   | MultiPassiveCB    | InitContextCB     | AppStatusCB+   deriving ( Eq, Ord )++isGlobal :: CallbackType -> Bool+isGlobal MenuStatusCB = True+isGlobal IdleCB       = True+isGlobal _            = False++--------------------------------------------------------------------------------+-- To uniquely identify a particular callback, the associated window is needed+-- for window callbacks.++data CallbackID = CallbackID (Maybe Window) CallbackType+   deriving ( Eq, Ord )++getCallbackID :: CallbackType -> IO CallbackID+getCallbackID callbackType = do+   maybeWindow <- if isGlobal callbackType+                     then return Nothing+                     else fmap Just $ getCurrentWindow "getCallbackID"+   return $ CallbackID maybeWindow callbackType++getCurrentWindow :: String -> IO Window+getCurrentWindow func = do+   win <- get currentWindow+   maybe (error (func ++ ": no current window")) return win++--------------------------------------------------------------------------------+-- This seems to be a common Haskell hack nowadays: A plain old global variable+-- with an associated mutator. Perhaps some language/library support is needed?++{-# NOINLINE theCallbackTable #-}+theCallbackTable :: IORef (CallbackTable a)+theCallbackTable = unsafePerformIO (newIORef emptyCallbackTable)++getCallbackTable :: IO (CallbackTable a)+getCallbackTable = readIORef theCallbackTable++modifyCallbackTable :: (CallbackTable a -> CallbackTable a) -> IO ()+modifyCallbackTable = modifyIORef theCallbackTable++--------------------------------------------------------------------------------++type CallbackTable a = Map CallbackID (FunPtr a)++emptyCallbackTable :: CallbackTable a+emptyCallbackTable = Map.empty++lookupInCallbackTable :: CallbackID -> IO (Maybe (FunPtr a))+lookupInCallbackTable callbackID =+   fmap (Map.lookup callbackID) getCallbackTable++deleteFromCallbackTable :: CallbackID -> IO ()+deleteFromCallbackTable callbackID =+   modifyCallbackTable (Map.delete callbackID)++addToCallbackTable :: CallbackID -> FunPtr a -> IO ()+addToCallbackTable callbackID funPtr =+   modifyCallbackTable (Map.insert callbackID funPtr)++--------------------------------------------------------------------------------+-- Another global mutable variable: The list of function pointers ready to be+-- freed by freeHaskellFunPtr++{-# NOINLINE theCleanupList #-}+theCleanupList :: IORef [FunPtr a]+theCleanupList = unsafePerformIO (newIORef [])++getCleanupList :: IO [FunPtr a]+getCleanupList = readIORef theCleanupList++setCleanupList :: [FunPtr a] -> IO ()+setCleanupList = writeIORef theCleanupList++--------------------------------------------------------------------------------+-- And yet another mutable (write-once) variable: A function pointer to a+-- callback which frees all function pointers on the cleanup list.++{-# NOINLINE theScavenger #-}+theScavenger :: IORef (FunPtr TimerFunc)+theScavenger = unsafePerformIO (newIORef =<< makeTimerFunc (\_ -> do+   cleanupList <- getCleanupList+   mapM_ freeHaskellFunPtr cleanupList+   setCleanupList []))++getScavenger :: IO (FunPtr TimerFunc)+getScavenger = readIORef theScavenger++--------------------------------------------------------------------------------+-- Here is the really cunning stuff: If an element is added to the cleanup list+-- when it is empty, register an immediate callback at GLUT to free the list as+-- soon as possible.++registerForCleanup :: FunPtr a -> IO ()+registerForCleanup funPtr = do+   oldCleanupList <- getCleanupList+   setCleanupList (funPtr : oldCleanupList)+   when (null oldCleanupList) $ do+        scavenger <- getScavenger+        glutTimerFunc 0 scavenger 0++--------------------------------------------------------------------------------++setCallback :: CallbackType -> (FunPtr a -> IO ()) -> (b -> IO (FunPtr a))+            -> Maybe b -> IO ()+setCallback callbackType registerAtGLUT makeCallback maybeCallback = do+   callbackID <- getCallbackID callbackType+   maybeOldFunPtr <- lookupInCallbackTable callbackID+   case maybeOldFunPtr of+      Nothing -> return ()+      Just oldFunPtr -> do registerForCleanup oldFunPtr+                           deleteFromCallbackTable callbackID+   case maybeCallback of+      Nothing -> registerAtGLUT nullFunPtr+      Just callback -> do newFunPtr <- makeCallback callback+                          addToCallbackTable callbackID newFunPtr+                          registerAtGLUT newFunPtr
+ src/Graphics/UI/GLUT/Callbacks/Window.hs view
@@ -0,0 +1,991 @@+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Callbacks.Window+-- Copyright   :  (c) Sven Panne 2002-2013+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- Stability   :  stable+-- Portability :  portable+--+--------------------------------------------------------------------------------++module Graphics.UI.GLUT.Callbacks.Window (+   -- * Redisplay callbacks+   DisplayCallback, displayCallback, overlayDisplayCallback,++   -- * Reshape callback+   ReshapeCallback, reshapeCallback,++   -- * Position callback+   PositionCallback, positionCallback,++   -- * Callbacks for visibility changes+   Visibility(..), VisibilityCallback, visibilityCallback,+   WindowState(..), WindowStateCallback, windowStateCallback,++   -- * Window close callback+   CloseCallback, closeCallback,++   -- * Life cycle callbacks for mobile platforms+   InitContextCallback, initContextCallback,+   AppStatus(..), AppStatusCallback, appStatusCallback,++   -- * Keyboard callback+   KeyboardCallback, keyboardCallback, keyboardUpCallback,++   -- * Special callback+   SpecialCallback, specialCallback, specialUpCallback,++   -- * Mouse callback+   MouseCallback, mouseCallback,++   -- * Keyboard and mouse input callback+   Key(..), SpecialKey(..), MouseButton(..), KeyState(..), Modifiers(..),+   KeyboardMouseCallback, keyboardMouseCallback,++   -- * Mouse wheel callback+   WheelNumber, WheelDirection, MouseWheelCallback, mouseWheelCallback,++   -- * Mouse movement callbacks+   MotionCallback, motionCallback, passiveMotionCallback,+   Crossing(..), CrossingCallback, crossingCallback,++   -- * Spaceball callback+   SpaceballMotion, SpaceballRotation, ButtonIndex, SpaceballInput(..),+   SpaceballCallback, spaceballCallback,++   -- * Dial & button box callback+   DialAndButtonBoxInput(..), DialIndex,+   DialAndButtonBoxCallback, dialAndButtonBoxCallback,++   -- * Tablet callback+   TabletPosition(..), TabletInput(..), TabletCallback, tabletCallback,++   -- * Joystick callback+   JoystickButtons(..), JoystickPosition(..),+   JoystickCallback, joystickCallback,++   -- * Multi-touch support+   TouchID,+   MultiMouseCallback, multiMouseCallback,+   MultiCrossingCallback, multiCrossingCallback,+   MultiMotionCallback, multiMotionCallback, multiPassiveMotionCallback++) where++import Data.Bits hiding ( shift )+import Data.Char+import Data.Maybe+import Foreign.C.Types+import Graphics.Rendering.OpenGL+import Graphics.UI.GLUT.Callbacks.Registration+import Graphics.UI.GLUT.Raw+import Graphics.UI.GLUT.State+import Graphics.UI.GLUT.Types++--------------------------------------------------------------------------------++-- | A display callback++type DisplayCallback = IO ()++-- | Controls the display callback for the /current window./ When GLUT determines+-- that the normal plane for the window needs to be redisplayed, the display+-- callback for the window is called. Before the callback, the /current window/+-- is set to the window needing to be redisplayed and (if no overlay display+-- callback is registered) the /layer in use/ is set to the normal plane. The+-- entire normal plane region should be redisplayed in response to the callback+-- (this includes ancillary buffers if your program depends on their state).+--+-- GLUT determines when the display callback should be triggered based on the+-- window\'s redisplay state. The redisplay state for a window can be either set+-- explicitly by calling 'Graphics.UI.GLUT.Window.postRedisplay' or implicitly+-- as the result of window damage reported by the window system. Multiple posted+-- redisplays for a window are coalesced by GLUT to minimize the number of+-- display callbacks called.+--+-- When an overlay is established for a window, but there is no overlay display+-- callback registered, the display callback is used for redisplaying both the+-- overlay and normal plane (that is, it will be called if either the redisplay+-- state or overlay redisplay state is set). In this case, the /layer in use/ is+-- not implicitly changed on entry to the display callback.+--+-- See 'overlayDisplayCallback' to understand how distinct callbacks for the+-- overlay and normal plane of a window may be established.+--+-- When a window is created, no display callback exists for the window. It is+-- the responsibility of the programmer to install a display callback for the+-- window before the window is shown. A display callback must be registered for+-- any window that is shown. If a window becomes displayed without a display+-- callback being registered, a fatal error occurs. There is no way to+-- \"deregister\" a display callback (though another callback routine can always+-- be registered).+--+-- Upon return from the display callback, the normal damaged state of the window+-- (see 'Graphics.UI.GLUT.State.damaged') is cleared. If there is no overlay+-- display callback registered the overlay damaged state of the window (see+-- 'Graphics.UI.GLUT.State.damaged') is also cleared.++displayCallback :: SettableStateVar DisplayCallback+displayCallback = makeSettableStateVar $+   setCallback DisplayCB glutDisplayFunc makeDisplayFunc . Just++--------------------------------------------------------------------------------++-- | Controls the overlay display callback for the /current window./ The overlay+-- display callback is functionally the same as the window\'s display callback+-- except that the overlay display callback is used to redisplay the window\'s+-- overlay.+--+-- When GLUT determines that the overlay plane for the window needs to be+-- redisplayed, the overlay display callback for the window is called. Before+-- the callback, the /current window/ is set to the window needing to be+-- redisplayed and the /layer in use/ is set to the overlay. The entire overlay+-- region should be redisplayed in response to the callback (this includes+-- ancillary buffers if your program depends on their state).+--+-- GLUT determines when the overlay display callback should be triggered based+-- on the window\'s overlay redisplay state. The overlay redisplay state for a+-- window can be either set explicitly by calling+-- 'Graphics.UI.GLUT.Overlay.postOverlayRedisplay' or implicitly as the result+-- of window damage reported by the window system. Multiple posted overlay+-- redisplays for a window are coalesced by GLUT to minimize the number of+-- overlay display callbacks called.+--+-- Upon return from the overlay display callback, the overlay damaged state of+-- the window (see 'Graphics.UI.GLUT.State.damaged') is cleared.+--+-- Initially there is no overlay display callback registered when an overlay is+-- established. See 'displayCallback' to understand how the display callback+-- alone is used if an overlay display callback is not registered.++overlayDisplayCallback :: SettableStateVar (Maybe DisplayCallback)+overlayDisplayCallback = makeSettableStateVar $+   setCallback OverlayDisplayCB glutOverlayDisplayFunc makeOverlayDisplayFunc++--------------------------------------------------------------------------------++-- | A reshape callback++type ReshapeCallback = Size -> IO ()++-- | Controls the reshape callback for the /current window./ The reshape callback+-- is triggered when a window is reshaped. A reshape callback is also triggered+-- immediately before a window\'s first display callback after a window is+-- created or whenever an overlay for the window is established. The parameter+-- of the callback specifies the new window size in pixels. Before the callback,+-- the /current window/ is set to the window that has been reshaped.+--+-- If a reshape callback is not registered for a window or 'reshapeCallback' is+-- set to 'Nothing' (to deregister a previously registered callback), the+-- default reshape callback is used. This default callback will simply call+--+-- @+-- 'Graphics.Rendering.OpenGL.GL.CoordTrans.viewport' ('Graphics.Rendering.OpenGL.GL.CoordTrans.Position' 0 0) ('Graphics.Rendering.OpenGL.GL.CoordTrans.Size' /width/ /height/)+-- @+--+-- on the normal plane (and on the overlay if one exists).+--+-- If an overlay is established for the window, a single reshape callback is+-- generated. It is the callback\'s responsibility to update both the normal+-- plane and overlay for the window (changing the layer in use as necessary).+--+-- When a top-level window is reshaped, subwindows are not reshaped. It is up to+-- the GLUT program to manage the size and positions of subwindows within a+-- top-level window. Still, reshape callbacks will be triggered for subwindows+-- when their size is changed using 'Graphics.UI.GLUT.Window.windowSize'.++reshapeCallback :: SettableStateVar (Maybe ReshapeCallback)+reshapeCallback = makeSettableStateVar $+   setCallback ReshapeCB glutReshapeFunc (makeReshapeFunc . unmarshal)+   where unmarshal cb w h = cb (Size (fromIntegral w) (fromIntegral h))++--------------------------------------------------------------------------------++-- | A position callback++type PositionCallback = Position -> IO ()++-- | (/freeglut only/) Controls the position callback for the /current window./+-- The position callback for a window is called when the position of a window+-- changes.++positionCallback :: SettableStateVar (Maybe PositionCallback)+positionCallback = makeSettableStateVar $+   setCallback PositionCB glutPositionFunc (makePositionFunc . unmarshal)+   where unmarshal cb x y = cb (Position (fromIntegral x) (fromIntegral y))++--------------------------------------------------------------------------------++-- | The visibility state of the /current window/++data Visibility+   = NotVisible -- ^ No part of the /current window/ is visible, i.e., until the+                --   window\'s visibility changes, all further rendering to the+                --   window is discarded.+   | Visible    -- ^ The /current window/ is totally or partially visible. GLUT+                --   considers a window visible if any pixel of the window is+                --   visible or any pixel of any descendant window is visible on+                --   the screen.+   deriving ( Eq, Ord, Show )++unmarshalVisibility :: CInt -> Visibility+unmarshalVisibility x+   | x == glut_NOT_VISIBLE = NotVisible+   | x == glut_VISIBLE = Visible+   | otherwise = error ("unmarshalVisibility: illegal value " ++ show x)++--------------------------------------------------------------------------------++-- | A visibility callback++type VisibilityCallback = Visibility -> IO ()++-- | Controls the visibility callback for the /current window./ The visibility+-- callback for a window is called when the visibility of a window changes.+--+-- If the visibility callback for a window is disabled and later re-enabled, the+-- visibility status of the window is undefined; any change in window visibility+-- will be reported, that is if you disable a visibility callback and re-enable+-- the callback, you are guaranteed the next visibility change will be reported.+--+-- Note that you can either use 'visibilityCallback' or 'windowStateCallback',+-- but not both, because the former is implemented via the latter.++visibilityCallback :: SettableStateVar (Maybe VisibilityCallback)+visibilityCallback = makeSettableStateVar $+   setCallback VisibilityCB glutVisibilityFunc+               (makeVisibilityFunc . unmarshal)+   where unmarshal cb  = cb . unmarshalVisibility++--------------------------------------------------------------------------------++-- | The window state of the /current window/++data WindowState+   = Unmapped          -- ^ The /current window/ is unmapped.+   | FullyRetained     -- ^ The /current window/ is unobscured.+   | PartiallyRetained -- ^ The /current window/ is partially obscured.+   | FullyCovered      -- ^ The /current window/ is fully obscured.+   deriving ( Eq, Ord, Show )++unmarshalWindowState :: CInt -> WindowState+unmarshalWindowState x+   | x == glut_HIDDEN = Unmapped+   | x == glut_FULLY_RETAINED = FullyRetained+   | x == glut_PARTIALLY_RETAINED = PartiallyRetained+   | x == glut_FULLY_COVERED = FullyCovered+   | otherwise = error ("unmarshalWindowState: illegal value " ++ show x)++--------------------------------------------------------------------------------++-- | A window state callback++type WindowStateCallback = WindowState -> IO ()++-- | Controls the window state callback for the+-- /current window./ The window state callback for a window is called when the+-- window state of a window changes.+--+-- If the window state callback for a window is disabled and later re-enabled,+-- the window state state of the window is undefined; any change in the window+-- state will be reported, that is if you disable a window state callback and+-- re-enable the callback, you are guaranteed the next window state change will+-- be reported.+--+-- Note that you can either use 'visibilityCallback' or 'windowStateCallback',+-- but not both, because the former is implemented via the latter.++windowStateCallback :: SettableStateVar (Maybe WindowStateCallback)+windowStateCallback = makeSettableStateVar $+   setCallback WindowStatusCB glutWindowStatusFunc+               (makeWindowStatusFunc . unmarshal)+   where unmarshal cb  = cb . unmarshalWindowState++--------------------------------------------------------------------------------++-- | A window close callback++type CloseCallback = IO ()++-- | Controls the window close callback for the /current window/.++closeCallback :: SettableStateVar (Maybe CloseCallback)+closeCallback = makeSettableStateVar $+   setCallback CloseCB glutCloseFunc makeCloseFunc++--------------------------------------------------------------------------------++-- | An initialize context callback++type InitContextCallback = IO ()++-- | (/freeglut only/) Controls the initialize context callback for the /current+-- window/.++initContextCallback :: SettableStateVar (Maybe InitContextCallback)+initContextCallback = makeSettableStateVar $+   setCallback InitContextCB glutInitContextFunc makeInitContextFunc++--------------------------------------------------------------------------------++-- | The application status of the /current window/++data AppStatus+   = AppStatusPause+   | AppStatusResume+   deriving ( Eq, Ord, Show )++unmarshalAppStatus :: CInt -> AppStatus+unmarshalAppStatus x+   | x == glut_APPSTATUS_PAUSE = AppStatusPause+   | x == glut_APPSTATUS_RESUME = AppStatusResume+   | otherwise = error ("unmarshalAppStatus: illegal value " ++ show x)++--------------------------------------------------------------------------------++-- | An application status callback++type AppStatusCallback = AppStatus -> IO ()++-- | Controls the application status callback for the /current window./++appStatusCallback :: SettableStateVar (Maybe AppStatusCallback)+appStatusCallback = makeSettableStateVar $+   setCallback AppStatusCB glutAppStatusFunc+               (makeAppStatusFunc . unmarshal)+   where unmarshal cb  = cb . unmarshalAppStatus++--------------------------------------------------------------------------------++-- | A keyboard callback++type KeyboardCallback = Char -> Position -> IO ()++setKeyboardCallback :: Maybe KeyboardCallback -> IO ()+setKeyboardCallback =+   setCallback KeyboardCB glutKeyboardFunc (makeKeyboardFunc . unmarshal)+   where unmarshal cb c x y = cb (chr (fromIntegral c))+                                 (Position (fromIntegral x) (fromIntegral y))++-- | Controls the keyboard callback for the /current window/. This is+-- activated only when a key is pressed.++keyboardCallback :: SettableStateVar (Maybe KeyboardCallback)+keyboardCallback = makeSettableStateVar setKeyboardCallback++--------------------------------------------------------------------------------++setKeyboardUpCallback :: Maybe KeyboardCallback -> IO ()+setKeyboardUpCallback =+   setCallback KeyboardUpCB glutKeyboardUpFunc+               (makeKeyboardUpFunc . unmarshal)+   where unmarshal cb c x y = cb (chr (fromIntegral c))+                                 (Position (fromIntegral x) (fromIntegral y))++-- | Controls the keyboard callback for the /current window/. This is+-- activated only when a key is released.++keyboardUpCallback :: SettableStateVar (Maybe KeyboardCallback)+keyboardUpCallback = makeSettableStateVar setKeyboardUpCallback++--------------------------------------------------------------------------------++-- | Special keys++data SpecialKey+   = KeyF1+   | KeyF2+   | KeyF3+   | KeyF4+   | KeyF5+   | KeyF6+   | KeyF7+   | KeyF8+   | KeyF9+   | KeyF10+   | KeyF11+   | KeyF12+   | KeyLeft+   | KeyUp+   | KeyRight+   | KeyDown+   | KeyPageUp+   | KeyPageDown+   | KeyHome+   | KeyEnd+   | KeyInsert+   | KeyNumLock+   | KeyBegin+   | KeyDelete+   | KeyShiftL+   | KeyShiftR+   | KeyCtrlL+   | KeyCtrlR+   | KeyAltL+   | KeyAltR+   | KeyUnknown Int -- ^ You should actually never encounter this value, it is+                    -- just here as a safeguard against future changes in the+                    -- native GLUT library.+   deriving ( Eq, Ord, Show )++unmarshalSpecialKey :: CInt -> SpecialKey+unmarshalSpecialKey x+   | x == glut_KEY_F1 = KeyF1+   | x == glut_KEY_F2 = KeyF2+   | x == glut_KEY_F3 = KeyF3+   | x == glut_KEY_F4 = KeyF4+   | x == glut_KEY_F5 = KeyF5+   | x == glut_KEY_F6 = KeyF6+   | x == glut_KEY_F7 = KeyF7+   | x == glut_KEY_F8 = KeyF8+   | x == glut_KEY_F9 = KeyF9+   | x == glut_KEY_F10 = KeyF10+   | x == glut_KEY_F11 = KeyF11+   | x == glut_KEY_F12 = KeyF12+   | x == glut_KEY_LEFT = KeyLeft+   | x == glut_KEY_UP = KeyUp+   | x == glut_KEY_RIGHT = KeyRight+   | x == glut_KEY_DOWN = KeyDown+   | x == glut_KEY_PAGE_UP = KeyPageUp+   | x == glut_KEY_PAGE_DOWN = KeyPageDown+   | x == glut_KEY_HOME = KeyHome+   | x == glut_KEY_END = KeyEnd+   | x == glut_KEY_INSERT = KeyInsert+   | x == glut_KEY_NUM_LOCK = KeyNumLock+   | x == glut_KEY_BEGIN = KeyBegin+   | x == glut_KEY_DELETE = KeyDelete+   | x == glut_KEY_SHIFT_L = KeyShiftL+   | x == glut_KEY_SHIFT_R = KeyShiftR+   | x == glut_KEY_CTRL_L = KeyCtrlL+   | x == glut_KEY_CTRL_R = KeyCtrlR+   | x == glut_KEY_ALT_L = KeyAltL+   | x == glut_KEY_ALT_R = KeyAltR+   | otherwise = KeyUnknown (fromIntegral x)++--------------------------------------------------------------------------------++-- | A special key callback++type SpecialCallback = SpecialKey -> Position -> IO ()++setSpecialCallback :: Maybe SpecialCallback -> IO ()+setSpecialCallback =+   setCallback SpecialCB glutSpecialFunc (makeSpecialFunc . unmarshal)+   where unmarshal cb k x y = cb (unmarshalSpecialKey k)+                                 (Position (fromIntegral x) (fromIntegral y))++-- | Controls the special key callback for the /current window/. This is+-- activated only when a special key is pressed.++specialCallback :: SettableStateVar (Maybe SpecialCallback)+specialCallback = makeSettableStateVar setSpecialCallback++--------------------------------------------------------------------------------++setSpecialUpCallback :: Maybe SpecialCallback -> IO ()+setSpecialUpCallback =+   setCallback SpecialUpCB glutSpecialUpFunc (makeSpecialUpFunc . unmarshal)+   where unmarshal cb k x y = cb (unmarshalSpecialKey k)+                                 (Position (fromIntegral x) (fromIntegral y))++-- | Controls the special key callback for the /current window/. This is+-- activated only when a special key is released.++specialUpCallback :: SettableStateVar (Maybe SpecialCallback)+specialUpCallback = makeSettableStateVar setSpecialUpCallback++--------------------------------------------------------------------------------++-- | The current state of a key or button++data KeyState+   = Down+   | Up+   deriving ( Eq, Ord, Show )++unmarshalKeyState :: CInt -> KeyState+unmarshalKeyState x+   | x == glut_DOWN = Down+   | x == glut_UP = Up+   | otherwise = error ("unmarshalKeyState: illegal value " ++ show x)++--------------------------------------------------------------------------------++-- | A mouse callback++type MouseCallback = MouseButton -> KeyState -> Position -> IO ()++setMouseCallback :: Maybe MouseCallback -> IO ()+setMouseCallback =+   setCallback MouseCB glutMouseFunc (makeMouseFunc . unmarshal)+   where unmarshal cb b s x y = cb (unmarshalMouseButton b)+                                   (unmarshalKeyState s)+                                   (Position (fromIntegral x) (fromIntegral y))++-- | Controls the mouse callback for the /current window/.++mouseCallback :: SettableStateVar (Maybe MouseCallback)+mouseCallback = makeSettableStateVar setMouseCallback++--------------------------------------------------------------------------------++-- | The state of the keyboard modifiers++data Modifiers = Modifiers { shift, ctrl, alt :: KeyState }+   deriving ( Eq, Ord, Show )++-- Could use fromBitfield + Enum/Bounded instances + marshalModifier instead...+unmarshalModifiers :: CInt -> Modifiers+unmarshalModifiers m = Modifiers {+   shift = if (m .&. glut_ACTIVE_SHIFT) /= 0 then Down else Up,+   ctrl  = if (m .&. glut_ACTIVE_CTRL ) /= 0 then Down else Up,+   alt   = if (m .&. glut_ACTIVE_ALT  ) /= 0 then Down else Up }++getModifiers :: IO Modifiers+getModifiers = fmap unmarshalModifiers glutGetModifiers++--------------------------------------------------------------------------------++-- | A generalized view of keys++data Key+   = Char Char+   | SpecialKey SpecialKey+   | MouseButton MouseButton+   deriving ( Eq, Ord, Show )++-- | A keyboard\/mouse callback++type KeyboardMouseCallback =+   Key -> KeyState -> Modifiers -> Position -> IO ()++-- | Controls the keyboard\/mouse callback for the /current window./ The+-- keyboard\/mouse callback for a window is called when the state of a key or+-- mouse button changes. The callback parameters indicate the new state of the+-- key\/button, the state of the keyboard modifiers, and the mouse location in+-- window relative coordinates.+--+-- Note that this is a convenience function that should not ordinarily be used+-- in conjunction with `keyboardCallback`, `keyboardUpCallback`,+-- `specialCallback`, `specialUpCallback`, or `mouseCallback`.++keyboardMouseCallback :: SettableStateVar (Maybe KeyboardMouseCallback)+keyboardMouseCallback = makeSettableStateVar setKeyboardMouseCallback++setKeyboardMouseCallback :: Maybe KeyboardMouseCallback -> IO ()+setKeyboardMouseCallback Nothing = do+   setKeyboardCallback   Nothing+   setKeyboardUpCallback Nothing+   setSpecialCallback    Nothing+   setSpecialUpCallback  Nothing+   setMouseCallback      Nothing+setKeyboardMouseCallback (Just cb) = do+   setKeyboardCallback   (Just (\c   p -> do m <- getModifiers+                                             cb (Char        c) Down m p))+   setKeyboardUpCallback (Just (\c   p -> do m <- getModifiers+                                             cb (Char        c) Up   m p))+   setSpecialCallback    (Just (\s   p -> do m <- getModifiers+                                             cb (SpecialKey  s) Down m p))+   setSpecialUpCallback  (Just (\s   p -> do m <- getModifiers+                                             cb (SpecialKey  s) Up   m p))+   setMouseCallback      (Just (\b s p -> do m <- getModifiers+                                             cb (MouseButton b) s    m p))++--------------------------------------------------------------------------------++type WheelNumber = Int++type WheelDirection = Int++type MouseWheelCallback = WheelNumber -> WheelDirection -> Position -> IO ()++-- | (/freeglut only/) Controls the mouse wheel callback for the+-- /current window./ The mouse wheel callback for a window is called when a+-- mouse wheel is used and the wheel number is greater than or equal to+-- 'Graphics.UI.GLUT.State.numMouseButtons'.++mouseWheelCallback :: SettableStateVar (Maybe MouseWheelCallback)+mouseWheelCallback = makeSettableStateVar $+   setCallback MouseWheelCB glutMouseWheelFunc (makeMouseWheelFunc . unmarshal)+   where unmarshal cb n d x y = cb (fromIntegral n) (fromIntegral d)+                                   (Position (fromIntegral x) (fromIntegral y))++--------------------------------------------------------------------------------++-- | A motion callback++type MotionCallback = Position -> IO ()++-- | Controls the motion callback for the /current window./ The motion callback+-- for a window is called when the mouse moves within the window while one or+-- more mouse buttons are pressed. The callback parameter indicates the mouse+-- location in window relative coordinates.++motionCallback :: SettableStateVar (Maybe MotionCallback)+motionCallback = makeSettableStateVar $+   setCallback MotionCB glutMotionFunc (makeMotionFunc . unmarshal)+   where unmarshal cb x y = cb (Position (fromIntegral x) (fromIntegral y))++--------------------------------------------------------------------------------++-- | Controls the passive motion callback for the /current window./ The passive+-- motion callback for a window is called when the mouse moves within the window+-- while /no/ mouse buttons are pressed. The callback parameter indicates the+-- mouse location in window relative coordinates.++passiveMotionCallback :: SettableStateVar (Maybe MotionCallback)+passiveMotionCallback = makeSettableStateVar $+   setCallback PassiveMotionCB glutPassiveMotionFunc+               (makePassiveMotionFunc . unmarshal)+   where unmarshal cb x y = cb (Position (fromIntegral x) (fromIntegral y))++--------------------------------------------------------------------------------++-- | The relation between the mouse pointer and the /current window/ has+-- changed.++data Crossing+   = WindowLeft    -- ^ The mouse pointer has left the /current window./+   | WindowEntered -- ^ The mouse pointer has entered the /current window./+   deriving ( Eq, Ord, Show )++unmarshalCrossing :: CInt -> Crossing+unmarshalCrossing x+   | x == glut_LEFT = WindowLeft+   | x == glut_ENTERED = WindowEntered+   | otherwise = error ("unmarshalCrossing: illegal value " ++ show x)++--------------------------------------------------------------------------------++-- | An enter\/leave callback++type CrossingCallback = Crossing -> IO ()++-- | Controls the mouse enter\/leave callback for the /current window./ Note+-- that some window systems may not generate accurate enter\/leave callbacks.+--+-- /X Implementation Notes:/ An X implementation of GLUT should generate+-- accurate enter\/leave callbacks.++crossingCallback :: SettableStateVar (Maybe CrossingCallback)+crossingCallback = makeSettableStateVar $+   setCallback CrossingCB glutEntryFunc (makeEntryFunc . unmarshal)+   where unmarshal cb = cb . unmarshalCrossing++--------------------------------------------------------------------------------++-- | Translation of the Spaceball along one axis, normalized to be in the range+-- of -1000 to +1000 inclusive++type SpaceballMotion = Int++-- | Rotation of the Spaceball along one axis, normalized to be in the range+-- of -1800 .. +1800 inclusive++type SpaceballRotation = Int++-- | The index of a specific buttons of an input device.++type ButtonIndex = Int++-- | The state of the Spaceball has changed.++data SpaceballInput+   = SpaceballMotion   SpaceballMotion SpaceballMotion SpaceballMotion+   | SpaceballRotation SpaceballRotation SpaceballRotation SpaceballRotation+   | SpaceballButton   ButtonIndex KeyState+   deriving ( Eq, Ord, Show )++-- | A SpaceballButton callback++type SpaceballCallback = SpaceballInput -> IO ()++-- | Controls the Spaceball callback for the /current window./ The Spaceball+-- callback for a window is called when the window has Spaceball input focus+-- (normally, when the mouse is in the window) and the user generates Spaceball+-- translations, rotations, or button presses. The number of available Spaceball+-- buttons can be determined with 'Graphics.UI.GLUT.State.numSpaceballButtons'.+--+-- Registering a Spaceball callback when a Spaceball device is not available has+-- no effect and is not an error. In this case, no Spaceball callbacks will be+-- generated.++spaceballCallback :: SettableStateVar (Maybe SpaceballCallback)+spaceballCallback = makeSettableStateVar setSpaceballCallback++setSpaceballCallback :: Maybe SpaceballCallback -> IO ()+setSpaceballCallback Nothing = do+   setSpaceballMotionCallback   Nothing+   setSpaceballRotationCallback Nothing+   setSpaceballButtonCallback   Nothing+setSpaceballCallback (Just cb) = do+   setSpaceballMotionCallback   (Just (\x y z -> cb (SpaceballMotion   x y z)))+   setSpaceballRotationCallback (Just (\x y z -> cb (SpaceballRotation x y z)))+   setSpaceballButtonCallback   (Just (\b s   -> cb (SpaceballButton   b s)))++--------------------------------------------------------------------------------++type SpaceballMotionCallback =+   SpaceballMotion -> SpaceballMotion -> SpaceballMotion -> IO ()++setSpaceballMotionCallback :: Maybe SpaceballMotionCallback -> IO ()+setSpaceballMotionCallback =+   setCallback SpaceballMotionCB glutSpaceballMotionFunc+               (makeSpaceballMotionFunc . unmarshal)+   where unmarshal cb x y z =+            cb (fromIntegral x) (fromIntegral y) (fromIntegral z)++--------------------------------------------------------------------------------++type SpaceballRotationCallback =+   SpaceballRotation -> SpaceballRotation -> SpaceballRotation -> IO ()++setSpaceballRotationCallback :: Maybe SpaceballRotationCallback -> IO ()+setSpaceballRotationCallback =+   setCallback SpaceballRotateCB glutSpaceballRotateFunc+               (makeSpaceballRotateFunc . unmarshal)+   where unmarshal cb x y z =+            cb (fromIntegral x) (fromIntegral y) (fromIntegral z)++--------------------------------------------------------------------------------++type SpaceballButtonCallback = ButtonIndex -> KeyState -> IO ()++setSpaceballButtonCallback :: Maybe SpaceballButtonCallback -> IO ()+setSpaceballButtonCallback =+   setCallback SpaceballButtonCB glutSpaceballButtonFunc+               (makeSpaceballButtonFunc . unmarshal)+   where unmarshal cb b s = cb (fromIntegral b) (unmarshalKeyState s)++--------------------------------------------------------------------------------++-- | The index of a specific dial of a dial and button box.++type DialIndex = Int++-- | The dial & button box state has changed.++data DialAndButtonBoxInput+   = DialAndButtonBoxButton ButtonIndex KeyState+   | DialAndButtonBoxDial   DialIndex Int+   deriving ( Eq, Ord, Show )++-- | A dial & button box callback++type DialAndButtonBoxCallback = DialAndButtonBoxInput -> IO ()++-- | Controls the dial & button box callback for the /current window./ The dial+-- & button box button callback for a window is called when the window has dial+-- & button box input focus (normally, when the mouse is in the window) and the+-- user generates dial & button box button presses or dial changes. The number+-- of available dial & button box buttons and dials can be determined with+-- 'Graphics.UI.GLUT.State.numDialsAndButtons'.+--+-- Registering a dial & button box callback when a dial & button box device is+-- not available is ineffectual and not an error. In this case, no dial & button+-- box button will be generated.++dialAndButtonBoxCallback :: SettableStateVar (Maybe DialAndButtonBoxCallback)+dialAndButtonBoxCallback = makeSettableStateVar setDialAndButtonBoxCallback++setDialAndButtonBoxCallback :: Maybe DialAndButtonBoxCallback -> IO ()+setDialAndButtonBoxCallback Nothing = do+   setButtonBoxCallback Nothing+   setDialsCallback     Nothing+setDialAndButtonBoxCallback (Just cb) = do+   setButtonBoxCallback (Just (\b s -> cb (DialAndButtonBoxButton b s)))+   setDialsCallback     (Just (\d x -> cb (DialAndButtonBoxDial   d x)))++--------------------------------------------------------------------------------++type ButtonBoxCallback = ButtonIndex -> KeyState -> IO ()++setButtonBoxCallback :: Maybe ButtonBoxCallback -> IO ()+setButtonBoxCallback =+   setCallback ButtonBoxCB glutButtonBoxFunc (makeButtonBoxFunc . unmarshal)+   where unmarshal cb b s = cb (fromIntegral b) (unmarshalKeyState s)++--------------------------------------------------------------------------------++type DialsCallback = DialIndex -> Int -> IO ()++setDialsCallback :: Maybe DialsCallback -> IO ()+setDialsCallback =+    setCallback DialsCB glutDialsFunc (makeDialsFunc . unmarshal)+    where unmarshal cb d x = cb (fromIntegral d) (fromIntegral x)++--------------------------------------------------------------------------------++-- | Absolute tablet position, with coordinates normalized to be in the range of+-- 0 to 2000 inclusive++data TabletPosition = TabletPosition Int Int+   deriving ( Eq, Ord, Show )++-- | The table state has changed.++data TabletInput+   = TabletMotion+   | TabletButton ButtonIndex KeyState+   deriving ( Eq, Ord, Show )++-- | A tablet callback++type TabletCallback = TabletInput -> TabletPosition -> IO ()++-- | Controls the tablet callback for the /current window./ The tablet callback+-- for a window is called when the window has tablet input focus (normally, when+-- the mouse is in the window) and the user generates tablet motion or button+-- presses. The number of available tablet buttons can be determined with+-- 'Graphics.UI.GLUT.State.numTabletButtons'.+--+-- Registering a tablet callback when a tablet device is not available is+-- ineffectual and not an error. In this case, no tablet callbacks will be+-- generated.++tabletCallback :: SettableStateVar (Maybe TabletCallback)+tabletCallback = makeSettableStateVar setTabletCallback++setTabletCallback :: Maybe TabletCallback -> IO ()+setTabletCallback Nothing = do+   setTabletMotionCallback Nothing+   setTabletButtonCallback Nothing+setTabletCallback (Just cb) = do+   setTabletMotionCallback (Just (\p     -> cb TabletMotion       p))+   setTabletButtonCallback (Just (\b s p -> cb (TabletButton b s) p))++--------------------------------------------------------------------------------++type TabletMotionCallback = TabletPosition -> IO ()++setTabletMotionCallback :: Maybe TabletMotionCallback -> IO ()+setTabletMotionCallback =+    setCallback TabletMotionCB glutTabletMotionFunc+                (makeTabletMotionFunc . unmarshal)+    where unmarshal cb x y =+             cb (TabletPosition (fromIntegral x) (fromIntegral y))++--------------------------------------------------------------------------------++type TabletButtonCallback = ButtonIndex -> KeyState -> TabletPosition -> IO ()++setTabletButtonCallback :: Maybe TabletButtonCallback -> IO ()+setTabletButtonCallback =+    setCallback TabletButtonCB glutTabletButtonFunc+                (makeTabletButtonFunc . unmarshal)+    where unmarshal cb b s x y =+             cb (fromIntegral b) (unmarshalKeyState s)+                (TabletPosition (fromIntegral x) (fromIntegral y))++--------------------------------------------------------------------------------++-- | The state of the joystick buttons++data JoystickButtons = JoystickButtons {+   joystickButtonA, joystickButtonB,+   joystickButtonC, joystickButtonD :: KeyState }+   deriving ( Eq, Ord, Show )++-- Could use fromBitfield + Enum/Bounded instances + unmarshalJoystickButton+-- instead...+unmarshalJoystickButtons :: CUInt -> JoystickButtons+unmarshalJoystickButtons m = JoystickButtons {+   joystickButtonA = if (m .&. glut_JOYSTICK_BUTTON_A) /= 0 then Down else Up,+   joystickButtonB = if (m .&. glut_JOYSTICK_BUTTON_B) /= 0 then Down else Up,+   joystickButtonC = if (m .&. glut_JOYSTICK_BUTTON_C) /= 0 then Down else Up,+   joystickButtonD = if (m .&. glut_JOYSTICK_BUTTON_D) /= 0 then Down else Up }++--------------------------------------------------------------------------------++-- | Absolute joystick position, with coordinates normalized to be in the range+-- of -1000 to 1000 inclusive. The signs of the three axes mean the following:+--+-- * negative = left, positive = right+--+-- * negative = towards player, positive = away+--+-- * if available (e.g. rudder): negative = down, positive = up++data JoystickPosition = JoystickPosition Int Int Int+   deriving ( Eq, Ord, Show )++--------------------------------------------------------------------------------++-- | A joystick callback++type JoystickCallback = JoystickButtons -> JoystickPosition -> IO ()++-- | Controls the joystick callback for the /current window./ The joystick+-- callback is called either due to polling of the joystick at the uniform timer+-- interval specified (if > 0) or in response to an explicit call of+-- 'Graphics.UI.GLUT.DeviceControl.forceJoystickCallback'.+--+-- /X Implementation Notes:/ Currently GLUT has no joystick support for X11.++-- joystickCallback :: SettableStateVar (Maybe JoystickCallback, PollRate)+joystickCallback :: SettableStateVar (Maybe (JoystickCallback, PollRate))+joystickCallback =+   makeSettableStateVar $ \maybeCBAndRate ->+      setCallback JoystickCB+                  (\f -> glutJoystickFunc f (fromIntegral (snd (fromJust maybeCBAndRate))))+                  (makeJoystickFunc . unmarshal)+                  (fmap fst maybeCBAndRate)+    where unmarshal cb b x y z = cb (unmarshalJoystickButtons b)+                                    (JoystickPosition (fromIntegral x)+                                                      (fromIntegral y)+                                                      (fromIntegral z))++--------------------------------------------------------------------------------++-- | A description where the multi-touch event is coming from, the freeglut+-- specs are very vague about the actual semantics. It contains the device ID+-- and\/or the cursor\/finger ID.++type TouchID = Int++-- | A multi-touch variant of 'MouseCallback'.++type MultiMouseCallback = TouchID -> MouseCallback++-- | (/freeglut only/) A multi-touch variant of 'mouseCallback'.++multiMouseCallback :: SettableStateVar (Maybe MultiMouseCallback)+multiMouseCallback = makeSettableStateVar $+   setCallback MultiButtonCB glutMultiButtonFunc (makeMultiButtonFunc . unmarshal)+   where unmarshal cb d x y b s = cb (fromIntegral d)+                                     (unmarshalMouseButton b)+                                     (unmarshalKeyState s)+                                     (Position (fromIntegral x) (fromIntegral y))++-- | A multi-touch variant of 'CrossingCallback'.++type MultiCrossingCallback = TouchID -> CrossingCallback++-- | (/freeglut only/) A multi-touch variant of 'crossingCallback'.++multiCrossingCallback :: SettableStateVar (Maybe MultiCrossingCallback)+multiCrossingCallback = makeSettableStateVar $+   setCallback MultiEntryCB glutMultiEntryFunc (makeMultiEntryFunc . unmarshal)+   where unmarshal cb d c = cb (fromIntegral d) (unmarshalCrossing c)++-- | A multi-touch variant of 'MotionCallback'.++type MultiMotionCallback = TouchID -> MotionCallback++-- | (/freeglut only/) A multi-touch variant of 'motionCallback'.++multiMotionCallback :: SettableStateVar (Maybe MultiMotionCallback)+multiMotionCallback = makeSettableStateVar $+   setCallback MultiMotionCB glutMultiMotionFunc (makeMultiMotionFunc . unmarshal)+   where unmarshal cb d x y =+            cb (fromIntegral d) (Position (fromIntegral x) (fromIntegral y))++-- | (/freeglut only/) A multi-touch variant of 'passiveMotionCallback'.++multiPassiveMotionCallback :: SettableStateVar (Maybe MultiMotionCallback)+multiPassiveMotionCallback = makeSettableStateVar $+   setCallback MultiPassiveCB glutMultiPassiveFunc (makeMultiPassiveFunc . unmarshal)+   where unmarshal cb d x y =+            cb (fromIntegral d) (Position (fromIntegral x) (fromIntegral y))
+ src/Graphics/UI/GLUT/Colormap.hs view
@@ -0,0 +1,110 @@+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Colormap+-- Copyright   :  (c) Sven Panne 2002-2013+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- Stability   :  stable+-- Portability :  portable+--+-- OpenGL supports both RGBA and color index rendering. The RGBA mode is+-- generally preferable to color index because more OpenGL rendering+-- capabilities are available and color index mode requires the loading of+-- colormap entries.+--+-- The GLUT color index state variables are used to read and write entries in a+-- window\'s color index colormap. Every GLUT color index window has its own+-- logical color index colormap. The size of a window\'s colormap can be+-- determined by reading 'numColorMapEntries'.+--+-- GLUT color index windows within a program can attempt to share colormap+-- resources by copying a single color index colormap to multiple windows using+-- 'copyColormap'. If possible GLUT will attempt to share the actual colormap.+-- While copying colormaps using 'copyColormap' can potentially allow sharing of+-- physical colormap resources, logically each window has its own colormap. So+-- changing a copied colormap of a window will force the duplication of the+-- colormap. For this reason, color index programs should generally load a+-- single color index colormap, copy it to all color index windows within the+-- program, and then not modify any colormap cells.+--+-- Use of multiple colormaps is likely to result in colormap installation+-- problems where some windows are displayed with an incorrect colormap due to+-- limitations on colormap resources.+--+--------------------------------------------------------------------------------++module Graphics.UI.GLUT.Colormap (+   colorMapEntry,+   copyColormap,+   numColorMapEntries,+   transparentIndex+) where++import Foreign.C.Types+import Graphics.Rendering.OpenGL ( GLfloat, GLint, Color3(..), Index1(..)+                                 , StateVar, makeStateVar, GettableStateVar+                                 , makeGettableStateVar )+import Graphics.UI.GLUT.QueryUtils+import Graphics.UI.GLUT.Raw+import Graphics.UI.GLUT.Types++--------------------------------------------------------------------------------++-- | Controls the color index colormap entry of the /current window/\'s logical+-- colormap for the /layer in use/. The /layer in use/ of the /current window/+-- should be a color index window. The color index should be zero or greater and+-- less than the total number of colormap entries for the window (see+-- 'numColorMapEntries') and different from an overlay\'s transparent index (see+-- 'transparentIndex').+--+-- If the /layer in use/\'s colormap was copied by reference, setting a colormap+-- entry will force the duplication of the colormap.++colorMapEntry :: Index1 GLint -> StateVar (Color3 GLfloat)+colorMapEntry (Index1 cell) =+   makeStateVar (getColorMapEntry (fromIntegral cell))+                (setColorMapEntry (fromIntegral cell))++setColorMapEntry :: CInt -> Color3 GLfloat -> IO ()+setColorMapEntry cell (Color3 r g b) = glutSetColor cell r g b++getColorMapEntry :: CInt -> IO (Color3 GLfloat)+getColorMapEntry cell = do+   r <- glutGetColor cell glut_RED+   g <- glutGetColor cell glut_GREEN+   b <- glutGetColor cell glut_BLUE+   return $ Color3 r g b++--------------------------------------------------------------------------------++-- | Copy (lazily if possible to promote sharing) the logical colormap from a+-- specified window to the /current window/\'s /layer in use/. The copy will be+-- from the normal plane to the normal plane; or from the overlay to the overlay+-- (never across different layers). Once a colormap has been copied, avoid+-- setting cells in the colormap via 'colorMapEntry' since that will force an+-- actual copy of the colormap if it was previously copied by reference.+-- 'copyColormap' should only be called when both the /current window/ and the+-- specified window are color index windows.++copyColormap :: Window -> IO ()+copyColormap (Window win) = glutCopyColormap win++--------------------------------------------------------------------------------++-- | Contains the number of entries in the colormap of the /current window/\'s+-- current layer (0 in RGBA mode).++numColorMapEntries :: GettableStateVar GLint+numColorMapEntries =+   makeGettableStateVar $ simpleGet fromIntegral glut_WINDOW_COLORMAP_SIZE++--------------------------------------------------------------------------------++-- | Contains the transparent color index of the overlay of the /current window/+-- or -1 if no overlay is in use.++transparentIndex :: GettableStateVar (Index1 GLint)+transparentIndex =+   makeGettableStateVar $+      layerGet (Index1 . fromIntegral) glut_TRANSPARENT_INDEX
+ src/Graphics/UI/GLUT/Debugging.hs view
@@ -0,0 +1,37 @@+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Debugging+-- Copyright   :  (c) Sven Panne 2002-2013+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- Stability   :  stable+-- Portability :  portable+--+-- This module contains a simple utility routine to report any pending GL+-- errors.+--+--------------------------------------------------------------------------------++module Graphics.UI.GLUT.Debugging (+   reportErrors+) where++import Graphics.Rendering.OpenGL ( Error(..), errors, get )+import System.Environment+import System.IO++--------------------------------------------------------------------------------++-- | Report any pending GL errors to stderr (which is typically the console).+-- If there are no pending errors, this routine does nothing. Note that the+-- error flags are reset after this action, i.e. there are no pending errors+-- left afterwards.++reportErrors :: IO ()+reportErrors = get errors >>= mapM_ reportError++reportError :: Error -> IO ()+reportError (Error _ msg) = do+   pn <- getProgName+   hPutStrLn stderr ("GLUT: Warning in " ++ pn ++ ": GL error: " ++ msg)
+ src/Graphics/UI/GLUT/DeviceControl.hs view
@@ -0,0 +1,122 @@+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.DeviceControl+-- Copyright   :  (c) Sven Panne 2002-2013+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- Stability   :  stable+-- Portability :  portable+--+-- GLUT offers some routines for controlling the key repeat and polling the+-- joystick.+--+--------------------------------------------------------------------------------++module Graphics.UI.GLUT.DeviceControl (+   GlobalKeyRepeat(..), globalKeyRepeat,+   PerWindowKeyRepeat(..), perWindowKeyRepeat,+   forceJoystickCallback+) where++import Foreign.C.Types+import Graphics.Rendering.OpenGL ( StateVar, makeStateVar )+import Graphics.UI.GLUT.QueryUtils+import Graphics.UI.GLUT.Raw++--------------------------------------------------------------------------------++-- | The state of the global key repeat++data GlobalKeyRepeat+   = GlobalKeyRepeatOff+   | GlobalKeyRepeatOn+   | GlobalKeyRepeatDefault+   deriving ( Eq, Ord, Show )++marshalGlobalKeyRepeat :: GlobalKeyRepeat -> CInt+marshalGlobalKeyRepeat x = case x of+   GlobalKeyRepeatOff -> glut_KEY_REPEAT_OFF+   GlobalKeyRepeatOn -> glut_KEY_REPEAT_ON+   GlobalKeyRepeatDefault -> glut_KEY_REPEAT_DEFAULT++unmarshalGlobalKeyRepeat :: CInt -> GlobalKeyRepeat+unmarshalGlobalKeyRepeat x+   | x == glut_KEY_REPEAT_OFF = GlobalKeyRepeatOff+   | x == glut_KEY_REPEAT_ON = GlobalKeyRepeatOn+   | x == glut_KEY_REPEAT_DEFAULT = GlobalKeyRepeatDefault+   | otherwise = error ("unmarshalGlobalKeyRepeat: illegal value " ++ show x)++--------------------------------------------------------------------------------++-- | Controls the key repeat mode for the window system on a global basis if+-- possible. If supported by the window system, the key repeat can either be+-- disabled, enabled, or set to the window system\'s default key repeat state.+--+-- /X Implementation Notes:/ X11 sends @KeyPress@ events repeatedly when the+-- window system\'s global auto repeat is enabled. 'perWindowKeyRepeat' can+-- prevent these auto repeated keystrokes from being reported as keyboard or+-- special callbacks, but there is still some minimal overhead by the X server+-- to continually stream @KeyPress@ events to the GLUT application. The+-- 'globalKeyRepeat' state variable can be used to actually disable the global+-- sending of auto repeated @KeyPress@ events. Note that 'globalKeyRepeat'+-- affects the global window system auto repeat state so other applications+-- will not auto repeat if you disable auto repeat globally through+-- 'globalKeyRepeat'. GLUT applications using the X11 GLUT implementation+-- should disable key repeat with 'globalKeyRepeat' to disable key repeats most+-- efficiently, but are responsible for explicitly restoring the default key+-- repeat state on exit.+--+-- /Win32 Implementation Notes:/ The Win32 implementation of 'globalKeyRepeat'+-- does nothing. The 'perWindowKeyRepeat' can be used in the Win32 GLUT+-- implementation to ignore repeated keys on a per-window basis without changing+-- the global window system key repeat.++globalKeyRepeat :: StateVar GlobalKeyRepeat+globalKeyRepeat =+   makeStateVar (deviceGet unmarshalGlobalKeyRepeat glut_DEVICE_KEY_REPEAT)+                (glutSetKeyRepeat . marshalGlobalKeyRepeat)++--------------------------------------------------------------------------------++-- | The state of the per-window key repeat++data PerWindowKeyRepeat+   = PerWindowKeyRepeatOff+   | PerWindowKeyRepeatOn+   deriving ( Eq, Ord, Show )++marshalPerWindowKeyRepeat :: PerWindowKeyRepeat -> CInt+marshalPerWindowKeyRepeat x = case x of+   PerWindowKeyRepeatOn -> 0+   PerWindowKeyRepeatOff -> 1++unmarshalPerWindowKeyRepeat :: CInt -> PerWindowKeyRepeat+unmarshalPerWindowKeyRepeat x+   | x == 0 = PerWindowKeyRepeatOn+   | otherwise = PerWindowKeyRepeatOff++--------------------------------------------------------------------------------++-- | Controls if auto repeat keystrokes are reported to the /current window./+-- Ignoring auto repeated keystrokes is generally done in conjunction with using+-- the 'Graphics.UI.GLUT.Callbacks.Window.keyboardMouseCallback'. If you do+-- not ignore auto repeated keystrokes, your GLUT application will experience+-- repeated release\/press callbacks. Games using the keyboard will typically+-- want to ignore key repeat.++perWindowKeyRepeat :: StateVar PerWindowKeyRepeat+perWindowKeyRepeat =+   makeStateVar+      (deviceGet unmarshalPerWindowKeyRepeat glut_DEVICE_IGNORE_KEY_REPEAT)+      (glutIgnoreKeyRepeat . marshalPerWindowKeyRepeat)++--------------------------------------------------------------------------------++-- | Execute the joystick callback set by+-- 'Graphics.UI.GLUT.Callbacks.Window.joystickCallback' once (if one exists).+-- This is done in a synchronous fashion within the current context, i.e. when+-- 'forceJoystickCallback' returns, the callback will have already happened.++forceJoystickCallback :: IO ()+forceJoystickCallback = glutForceJoystickFunc
+ src/Graphics/UI/GLUT/Fonts.hs view
@@ -0,0 +1,120 @@+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Fonts+-- Copyright   :  (c) Sven Panne 2002-2013+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- Stability   :  stable+-- Portability :  portable+--+-- GLUT supports two types of font rendering: stroke fonts, meaning each+-- character is rendered as a set of line segments; and bitmap fonts, where each+-- character is a bitmap generated with+-- 'Graphics.Rendering.OpenGL.GL.Bitmaps.bitmap'. Stroke fonts have the+-- advantage that because they are geometry, they can be arbitrarily scale and+-- rendered. Bitmap fonts are less flexible since they are rendered as bitmaps+-- but are usually faster than stroke fonts.+--+--------------------------------------------------------------------------------++module Graphics.UI.GLUT.Fonts (+   Font(..), BitmapFont(..), StrokeFont(..),+) where++import Data.Char+import Foreign.C.String+import Foreign.C.Types+import Foreign.Ptr+import Graphics.Rendering.OpenGL+import Graphics.UI.GLUT.Raw++--------------------------------------------------------------------------------++class Font a where+   -- | Render the string in the named font, without using any display lists.+   -- Rendering a nonexistent character has no effect.+   --+   -- If the font is a bitmap font, 'renderString' automatically sets the OpenGL+   -- unpack pixel storage modes it needs appropriately and saves and restores+   -- the previous modes before returning. The generated call to+   -- 'Graphics.Rendering.OpenGL.GL.bitmap' will adjust the current raster+   -- position based on the width of the string.+   -- If the font is a stroke font,+   -- 'Graphics.Rendering.OpenGL.GL.CoordTrans.translate' is used to translate+   -- the current model view matrix to advance the width of the string.++   renderString :: a -> String -> IO ()++   -- | For a bitmap font, return the width in pixels of a string. For a stroke+   -- font, return the width in units. While the width of characters in a font+   -- may vary (though fixed width fonts do not vary), the maximum height+   -- characteristics of a particular font are fixed.++   stringWidth :: a -> String -> IO GLint++   -- | (/freeglut only/) For a bitmap font, return the maximum height of the+   -- characters in the given font measured in pixels. For a stroke font,+   -- return the width in units.++   fontHeight :: a -> IO GLfloat++instance Font BitmapFont where+   renderString = bitmapString+   stringWidth  = bitmapLength+   fontHeight   = bitmapHeight+++instance Font StrokeFont where+   renderString = strokeString+   stringWidth  = strokeLength+   fontHeight   = strokeHeight++--------------------------------------------------------------------------------++bitmapString :: BitmapFont -> String -> IO ()+bitmapString f s = do+   i <- marshalBitmapFont f+   mapM_ (\c -> withChar c (glutBitmapCharacter i)) s++withChar :: Char -> (CInt -> IO a) -> IO a+withChar c f = f . fromIntegral . ord $ c++--------------------------------------------------------------------------------++strokeString :: StrokeFont -> String -> IO ()+strokeString f s = do+   i <- marshalStrokeFont f+   mapM_ (\c -> withChar c (glutStrokeCharacter i)) s++--------------------------------------------------------------------------------++bitmapLength :: BitmapFont -- ^ Bitmap font to use.+             -> String     -- ^ String to return width of (not confined to 8+                           --   bits).+             -> IO GLint   -- ^ Width in pixels.+bitmapLength f s = do+   i <- marshalBitmapFont f+   fmap fromIntegral $ withCString s (glutBitmapLength i . castPtr)++--------------------------------------------------------------------------------++strokeLength :: StrokeFont -- ^ Stroke font to use.+             -> String     -- ^ String to return width of (not confined to 8+                           --   bits).+             -> IO GLint   -- ^ Width in units.+strokeLength f s = do+   i <- marshalStrokeFont f+   fmap fromIntegral $ withCString s (glutStrokeLength i . castPtr)++--------------------------------------------------------------------------------++bitmapHeight :: BitmapFont -- ^ Bitmap font to use.+             -> IO GLfloat -- ^ Height in pixels.+bitmapHeight f = fmap fromIntegral $ glutBitmapHeight =<< marshalBitmapFont f++--------------------------------------------------------------------------------++strokeHeight :: StrokeFont -- ^ Stroke font to use.+             -> IO GLfloat -- ^ Height in units.+strokeHeight f = glutStrokeHeight =<< marshalStrokeFont f
+ src/Graphics/UI/GLUT/GameMode.hs view
@@ -0,0 +1,191 @@+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.GameMode+-- Copyright   :  (c) Sven Panne 2002-2013+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- Stability   :  stable+-- Portability :  portable+--+-- In addition to the functionality offered by+-- 'Graphics.UI.GLUT.Window.fullScreen', GLUT offers an sub-API to change the+-- screen resolution, color depth, and refresh rate of the display for a single+-- full screen window. This mode of operation is called /game mode/, and is+-- restricted in various ways: No pop-up menus are allowed for this full screen+-- window, no other (sub-)windows can be created, and all other applications are+-- hidden.+--+-- /X Implementation Notes:/ Note that game mode is not fully supported in the+-- original GLUT for X, it is essentially the same as using+-- 'Graphics.UI.GLUT.Window.fullScreen'. The GLUT clone freeglut+-- (see <http://freeglut.sourceforge.net/>) does not have this restriction.+--+--------------------------------------------------------------------------------++module Graphics.UI.GLUT.GameMode (+   GameModeCapability(..), GameModeCapabilityDescription(..),+   gameModeCapabilities, enterGameMode, leaveGameMode,+   BitsPerPlane, RefreshRate, GameModeInfo(..), gameModeInfo,+   gameModeActive+) where++import Data.List+import Foreign.C.String+import Graphics.Rendering.OpenGL ( GLenum, Size(..)+                                 , GettableStateVar+                                 , SettableStateVar+                                 , makeGettableStateVar+                                 , makeSettableStateVar )+import Graphics.UI.GLUT.Raw+import Graphics.UI.GLUT.Types++--------------------------------------------------------------------------------++-- | Capabilities for 'gameModeCapabilities'++data GameModeCapability+   = GameModeWidth         -- ^ Width of the screen resolution in pixels+   | GameModeHeight        -- ^ Height of the screen resolution in pixels+   | GameModeBitsPerPlane  -- ^ Color depth of the screen in bits+   | GameModeRefreshRate   -- ^ Refresh rate in Hertz+   | GameModeNum           -- ^ Match the Nth frame buffer configuration+                           --   compatible with the given capabilities+                           --   (numbering starts at 1)+   deriving ( Eq, Ord, Show )++gameModeCapabilityToString :: GameModeCapability -> String+gameModeCapabilityToString x = case x of+   GameModeWidth        -> "width"+   GameModeHeight       -> "height"+   GameModeBitsPerPlane -> "bpp"+   GameModeRefreshRate  -> "hertz"+   GameModeNum          -> "num"++-- | A single capability description for 'gameModeCapabilities'.++data GameModeCapabilityDescription = Where' GameModeCapability Relation Int+   deriving ( Eq, Ord, Show )++gameModeCapabilityDescriptionToString :: GameModeCapabilityDescription -> String+gameModeCapabilityDescriptionToString (Where' c r i) =+      gameModeCapabilityToString c ++ relationToString r ++ show i++--------------------------------------------------------------------------------++-- | Controls the /game mode/ to be used when 'enterGameMode' is called. It is+-- described by a list of zero or more capability descriptions, which are+-- translated into a set of criteria used to select the appropriate screen+-- configuration. The criteria are matched in strict left to right order of+-- precdence. That is, the first specified criterion (leftmost) takes precedence+-- over the later criteria for non-exact criteria+-- ('Graphics.UI.GLUT.Initialization.IsGreaterThan',+-- 'Graphics.UI.GLUT.Initialization.IsLessThan', etc.). Exact criteria+-- ('Graphics.UI.GLUT.Initialization.IsEqualTo',+-- 'Graphics.UI.GLUT.Initialization.IsNotEqualTo') must match exactly so+-- precedence is not relevant.+--+-- To determine which configuration will actually be tried by 'enterGameMode'+-- (if any), use 'gameModeInfo'.+--+-- Note that even for game mode the current values of+-- 'Graphics.UI.GLUT.Initialization.initialDisplayMode'or+-- 'Graphics.UI.GLUT.Initialization.initialDisplayCapabilities' will+-- determine which buffers are available, if double buffering is used or not,+-- etc.++gameModeCapabilities :: SettableStateVar [GameModeCapabilityDescription]+gameModeCapabilities = makeSettableStateVar $ \ds ->+   withCString (descriptionsToString ds) glutGameModeString++-- freeglut currently handles only simple game mode descriptions like "WxH:B@R",+-- so we try hard to use this format instead of the more general format allowed+-- by the "real" GLUT.+descriptionsToString :: [GameModeCapabilityDescription] -> String+descriptionsToString ds =+   let ws = [ x | Where' GameModeWidth        IsEqualTo x <- ds ]+       hs = [ x | Where' GameModeHeight       IsEqualTo x <- ds ]+       bs = [ x | Where' GameModeBitsPerPlane IsEqualTo x <- ds ]+       rs = [ x | Where' GameModeRefreshRate  IsEqualTo x <- ds ]+       allSimple = (length ws + length hs + length bs + length rs) == (length ds)+       dimensionsOK = (null ws) == (null hs)+   in if allSimple && dimensionsOK+         then simpleCapStr ws hs bs rs+         else generalCapStr ds++simpleCapStr :: [Int] -> [Int] -> [Int] -> [Int] -> String+simpleCapStr ws hs bs rs =+   showCap "" ws ++ showCap "x" hs ++ showCap ":" bs ++ showCap "@" rs+   where showCap _      []    = ""+         showCap prefix (x:_) = prefix ++ show x++generalCapStr :: [GameModeCapabilityDescription] -> String+generalCapStr =+   concat . intersperse " " . map gameModeCapabilityDescriptionToString++--------------------------------------------------------------------------------++-- | Enter /game mode/, trying to change resolution, refresh rate, etc., as+-- specified by the current value of 'gameModeCapabilities'. An identifier for+-- the game mode window and a flag, indicating if the display mode actually+-- changed, are returned. The game mode window is made the /current window/.+--+-- Re-entering /game mode/ is allowed, the previous game mode window gets+-- destroyed by this, and a new one is created.++enterGameMode :: IO (Window, Bool)+enterGameMode = do+   w <- glutEnterGameMode+   c <- getBool glut_GAME_MODE_DISPLAY_CHANGED+   return (Window w, c)++--------------------------------------------------------------------------------++-- | Leave /game mode/, restoring the old display mode and destroying the game+-- mode window.++leaveGameMode :: IO ()+leaveGameMode = glutLeaveGameMode++--------------------------------------------------------------------------------++-- | The color depth of the screen, measured in bits (e.g. 8, 16, 24, 32, ...)++type BitsPerPlane = Int++-- | The refresh rate of the screen, measured in Hertz (e.g. 60, 75, 100, ...)++type RefreshRate = Int++data GameModeInfo = GameModeInfo Size BitsPerPlane RefreshRate+   deriving ( Eq, Ord, Show )++--------------------------------------------------------------------------------++-- | Return 'Just' the mode which would be tried by the next call to+-- 'enterGameMode'. Returns 'Nothing' if the mode requested by the current value+-- of 'gameModeCapabilities' is not possible, in which case 'enterGameMode'+-- would simply create a full screen window using the current mode.++gameModeInfo :: GettableStateVar (Maybe GameModeInfo)+gameModeInfo = makeGettableStateVar $ do+   possible <- getBool glut_GAME_MODE_POSSIBLE+   if possible+      then do+         w <- glutGameModeGet glut_GAME_MODE_WIDTH+         h <- glutGameModeGet glut_GAME_MODE_HEIGHT+         let size = Size (fromIntegral w) (fromIntegral h)+         b <- glutGameModeGet glut_GAME_MODE_PIXEL_DEPTH+         r <- glutGameModeGet glut_GAME_MODE_REFRESH_RATE+         return $ Just $ GameModeInfo size (fromIntegral b) (fromIntegral r)+      else return Nothing++getBool :: GLenum -> IO Bool+getBool = fmap (/= 0) . glutGameModeGet++--------------------------------------------------------------------------------++-- | Contains 'True' when the /game mode/ is active, 'False' otherwise.++gameModeActive :: GettableStateVar Bool+gameModeActive = makeGettableStateVar $ getBool glut_GAME_MODE_ACTIVE
+ src/Graphics/UI/GLUT/Initialization.hs view
@@ -0,0 +1,773 @@+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Initialization+-- Copyright   :  (c) Sven Panne 2002-2013+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- Stability   :  stable+-- Portability :  portable+--+-- Actions and state variables in this module are used to initialize GLUT state.+-- The primary initialization routine is 'initialize', which should only be+-- called exactly once in a GLUT program. No other GLUT or OpenGL actions should+-- be called before 'initialize', apart from getting or setting the state+-- variables in this module.+--+-- The reason is that these state variables can be used to set default window+-- initialization state that might be modified by the command processing done in+-- 'initialize'. For example, 'initialWindowSize' can be set to @('Size'+-- 400 400)@ before 'initialize' is called to indicate 400 by 400 is the+-- program\'s default window size. Setting the initial window size or position+-- before 'initialize' allows the GLUT program user to specify the initial size+-- or position using command line arguments.+--+--------------------------------------------------------------------------------++module Graphics.UI.GLUT.Initialization (+   -- * Primary initialization+   initialize, getArgsAndInitialize, exit,++   -- * Initial window geometry+   initialWindowPosition, initialWindowSize,++   -- * Setting the initial display mode (I)+   DisplayMode(..), initialDisplayMode, displayModePossible,++   -- * Setting the initial display mode (II)+   DisplayCapability(..), Relation(..), DisplayCapabilityDescription(..),+   initialDisplayCapabilities,++   -- * Controlling the creation of rendering contexts+   RenderingContext(..), renderingContext,++   -- * Direct\/indirect rendering+   DirectRendering(..), directRendering,++   -- * OpenGL 3.x context support+   initialContextVersion, ContextFlag(..), initialContextFlags,+   ContextProfile(..), initialContextProfile+) where++import Control.Monad+import Data.Bits+import Data.List+import Foreign.C.String+import Foreign.C.Types+import Foreign.Marshal.Array+import Foreign.Marshal.Utils+import Foreign.Ptr+import Foreign.Storable+import Graphics.Rendering.OpenGL ( Position(..), Size(..)+                                 , StateVar, GettableStateVar, get+                                 , SettableStateVar, makeStateVar, ($=)+                                 , makeGettableStateVar+                                 , makeSettableStateVar )+import Graphics.UI.GLUT.QueryUtils+import Graphics.UI.GLUT.Raw+import Graphics.UI.GLUT.Types+import System.Environment++--------------------------------------------------------------------------------++-- | Given the program name and command line arguments, initialize the GLUT+-- library and negotiate a session with the window system. During this+-- process, 'initialize' may cause the termination of the GLUT program with an+-- error message to the user if GLUT cannot be properly initialized.+-- Examples of this situation include the failure to connect to the window+-- system, the lack of window system support for OpenGL, and invalid command+-- line options.+--+-- 'initialize' also processes command line options, but the specific options+-- parsed are window system dependent. Any command line arguments which are+-- not GLUT-specific are returned.+--+-- /X Implementation Notes:/ The X Window System specific options parsed by+-- 'initialize' are as follows:+--+-- * @-display /DISPLAY/@: Specify the X server to connect to. If not specified,+--   the value of the @DISPLAY@ environment variable is used.+--+-- * @-geometry /WxH+X+Y/@: Determines where windows should be created on the+--   screen. The parameter following @-geometry@ should be formatted as a+--   standard X geometry specification. The effect of using this option is to+--   change the GLUT initial size and initial position the same as if+--   'initialWindowSize' or 'initialWindowPosition' were modified directly.+--+-- * @-iconic@: Requests all top-level windows be created in an iconic state.+--+-- * @-indirect@: Force the use of indirect OpenGL rendering contexts.+--+-- * @-direct@: Force the use of direct OpenGL rendering contexts (not all GLX+--   implementations support direct rendering contexts). A fatal error is+--   generated if direct rendering is not supported by the OpenGL+--   implementation. If neither @-indirect@ or @-direct@ are used to force a+--   particular behavior, GLUT will attempt to use direct rendering if+--   possible and otherwise fallback to indirect rendering.+--+-- * @-gldebug@: After processing callbacks and\/or events, call+--   'Graphics.UI.GLUT.Debugging.reportErrors' to check if there are any pending+--   OpenGL errors. Using this option is helpful in detecting OpenGL run-time+--   errors.+--+-- * @-sync@: Enable synchronous X protocol transactions. This option makes+--   it easier to track down potential X protocol errors.++initialize :: String      -- ^ The program name.+           -> [String]    -- ^ The command line arguments+           -> IO [String] -- ^ Non-GLUT command line arguments+initialize prog args =+   with (1 + genericLength args) $ \argcBuf ->+   withMany withCString (prog : args) $ \argvPtrs ->+   withArray0 nullPtr argvPtrs $ \argvBuf -> do+   glutInit argcBuf argvBuf+   newArgc <- peek argcBuf+   newArgvPtrs <- peekArray (fromIntegral newArgc) argvBuf+   newArgv <- mapM peekCString newArgvPtrs+   return $ tail newArgv++-- | Convenience action: Initialize GLUT, returning the program name and any+-- non-GLUT command line arguments.++getArgsAndInitialize :: IO (String, [String])+getArgsAndInitialize = do+   prog <- getProgName+   args <- getArgs+   nonGLUTArgs <- initialize prog args+   return (prog, nonGLUTArgs)++-----------------------------------------------------------------------------++-- | (/freeglut only/) De-initialize GLUT. After this, one has to use+-- 'initialize' or 'getArgsAndInitialize' to initialize GLUT again.++exit :: IO ()+exit = glutExit++--------------------------------------------------------------------------------++-- | Controls the /initial window position/.  Windows created by+-- 'Graphics.UI.GLUT.Window.createWindow' will be requested to be created with+-- the current /initial window position/. The initial value of the /initial+-- window position/ GLUT state is @'Position' (-1) (-1)@. If either the X or Y+-- component of the /initial window position/ is negative, the actual window+-- position is left to the window system to determine.+--+-- The intent of the /initial window position/ is to provide a suggestion to+-- the window system for a window\'s initial position. The window system is+-- not obligated to use this information. Therefore, GLUT programs should not+-- assume the window was created at the specified position.++initialWindowPosition :: StateVar Position+initialWindowPosition =+   makeStateVar getInitialWindowPosition setInitialWindowPosition++getInitialWindowPosition :: IO Position+getInitialWindowPosition = do+   x <- simpleGet fromIntegral glut_INIT_WINDOW_X+   y <- simpleGet fromIntegral glut_INIT_WINDOW_Y+   return $ Position x y++setInitialWindowPosition :: Position -> IO ()+setInitialWindowPosition (Position x y) =+    glutInitWindowPosition (fromIntegral x) (fromIntegral y)++--------------------------------------------------------------------------------++-- | Controls the /initial window size/.  Windows created by+-- 'Graphics.UI.GLUT.Window.createWindow' will be requested to be created with+-- the current /initial window size/. The initial value of the /initial window+-- size/ GLUT state is @'Size' 300 300@. If either the width or the height+-- component of the /initial window size/ is non-positive, the actual window+-- size is left to the window system to determine.+--+-- The intent of the /initial window size/ is to provide a suggestion to the+-- window system for a window\'s initial size. The window system is not+-- obligated to use this information. Therefore, GLUT programs should not+-- assume the window was created at the specified size. A GLUT program should+-- use the window\'s reshape callback to determine the true size of the+-- window.++initialWindowSize :: StateVar Size+initialWindowSize = makeStateVar getInitialWindowSize setInitialWindowSize++getInitialWindowSize :: IO Size+getInitialWindowSize = do+   w <- simpleGet fromIntegral glut_INIT_WINDOW_WIDTH+   h <- simpleGet fromIntegral glut_INIT_WINDOW_HEIGHT+   return $ Size w h++setInitialWindowSize :: Size -> IO ()+setInitialWindowSize (Size w h) =+   glutInitWindowSize (fromIntegral w) (fromIntegral h)++--------------------------------------------------------------------------------++-- | A single aspect of a window which is to be created, used in conjunction+-- with 'initialDisplayMode'.++data DisplayMode+   = RGBAMode+     -- ^ Select an RGBA mode window. This is the default if neither 'RGBAMode'+     -- nor 'IndexMode' are specified.+   | RGBMode+     -- ^ An alias for 'RGBAMode'.+   | IndexMode+     -- ^ Select a color index mode window. This overrides 'RGBAMode' if it is+     -- also specified.+   | LuminanceMode+     -- ^ Select a window with a \"luminance\" color model. This model provides+     -- the functionality of OpenGL\'s RGBA color model, but the green and blue+     -- components are not maintained in the frame buffer. Instead each pixel\'s+     -- red component is converted to an index between zero and+     --  'Graphics.UI.GLUT.Colormap.numColorMapEntries' and looked up in a+     -- per-window color map to determine the color of pixels within the window.+     -- The initial colormap of 'LuminanceMode' windows is initialized to be a+     -- linear gray ramp, but can be modified with GLUT\'s colormap actions.+     -- /Implementation Notes:/ 'LuminanceMode' is not supported on most OpenGL+     -- platforms.+   | WithAlphaComponent+     -- ^ Select a window with an alpha component to the color buffer(s).+   | WithAccumBuffer+     -- ^ Select a window with an accumulation buffer.+   | WithDepthBuffer+     -- ^ Select a window with a depth buffer.+   | WithStencilBuffer+     -- ^ Select a window with a stencil buffer.+   | WithAuxBuffers Int+     -- ^ (/freeglut only/) Select a window with /n/ (1 .. 4) auxiliary buffers.+     -- Any /n/ outside the range 1 .. 4 is a fatal error.+   | SingleBuffered+     -- ^ Select a single buffered window. This is the default if neither+     -- 'DoubleBuffered' nor 'SingleBuffered' are specified.+   | DoubleBuffered+     -- ^ Select a double buffered window. This overrides 'SingleBuffered' if it+     -- is also specified.+   | Multisampling+     -- ^ Select a window with multisampling support. If multisampling is not+     -- available, a non-multisampling window will automatically be chosen.+     -- Note: both the OpenGL client-side and server-side implementations must+     -- support the @GLX_SAMPLE_SGIS@ extension for multisampling to be+     -- available. Deprecated, use 'WithSamplesPerPixel'.+   | WithSamplesPerPixel Int+     -- ^ Select a window with multisampling, using the given samples per pixel.+   | Stereoscopic+     -- ^ Select a stereo window.+   | Captionless+     -- ^ Select a window without a caption (/freeglut only/).+   | Borderless+     -- ^ Select a window without any borders (/freeglut only/).+   | SRGBMode+     -- ^ Select an sRGB mode window (/freeglut only/).+   deriving ( Eq, Ord, Show )++marshalDisplayMode :: DisplayMode -> CUInt+marshalDisplayMode m = case m of+   RGBAMode -> glut_RGBA+   RGBMode -> glut_RGB+   IndexMode -> glut_INDEX+   LuminanceMode -> glut_LUMINANCE+   WithAlphaComponent -> glut_ALPHA+   WithAccumBuffer -> glut_ACCUM+   WithDepthBuffer -> glut_DEPTH+   WithStencilBuffer -> glut_STENCIL+   WithAuxBuffers 1 -> glut_AUX1+   WithAuxBuffers 2 -> glut_AUX2+   WithAuxBuffers 3 -> glut_AUX3+   WithAuxBuffers 4 -> glut_AUX4+   WithAuxBuffers n ->+      error ("marshalDisplayMode: illegal number of auxiliary buffers: " ++ show n)+   SingleBuffered -> glut_SINGLE+   DoubleBuffered -> glut_DOUBLE+   Multisampling -> glut_MULTISAMPLE+   WithSamplesPerPixel _ -> error ("marshalDisplayMode: this should not happen")+   Stereoscopic -> glut_STEREO+   Captionless -> glut_CAPTIONLESS+   Borderless -> glut_BORDERLESS+   SRGBMode -> glut_SRGB++--------------------------------------------------------------------------------++-- | Controls the /initial display mode/ used when creating top-level windows,+-- subwindows, and overlays to determine the OpenGL display mode for the+-- to-be-created window or overlay.+--+-- Note that 'RGBAMode' selects the RGBA color model, but it does not request any+-- bits of alpha (sometimes called an /alpha buffer/ or /destination alpha/)+-- be allocated. To request alpha, specify 'WithAlphaComponent'. The same+-- applies to 'LuminanceMode'.++initialDisplayMode :: StateVar [DisplayMode]+initialDisplayMode = makeStateVar getInitialDisplayMode setInitialDisplayMode++getInitialDisplayMode :: IO [DisplayMode]+getInitialDisplayMode = do+   mode <- simpleGet fromIntegral glut_INIT_DISPLAY_MODE+   let displayModes = i2dms (mode .&. complement glut_MULTISAMPLE)+   if mode .&. glut_MULTISAMPLE == 0+      then return displayModes+      else do+         n <- get samplesPerPixel+         return $ WithSamplesPerPixel n : displayModes++i2dms :: CUInt -> [DisplayMode]+i2dms bitfield | IndexMode `elem` modes || LuminanceMode `elem` modes = modes+               | otherwise = RGBAMode : modes+   where modes = i2dmsWithoutRGBA bitfield++i2dmsWithoutRGBA :: CUInt -> [DisplayMode]+i2dmsWithoutRGBA bitfield =+   [ c | c <- [ IndexMode, LuminanceMode, WithAlphaComponent,+                WithAccumBuffer, WithDepthBuffer, WithStencilBuffer,+                WithAuxBuffers 1, WithAuxBuffers 2, WithAuxBuffers 3,+                WithAuxBuffers 4, SingleBuffered, DoubleBuffered, Multisampling,+                Stereoscopic, Captionless, Borderless, SRGBMode ]+       , (bitfield .&. marshalDisplayMode c) /= 0 ]++setInitialDisplayMode :: [DisplayMode] -> IO ()+setInitialDisplayMode modes = do+   let (spps, transformedModes) = mapAccumR handleMultisampling [] modes+   mapM_ (samplesPerPixel $=) spps+   glutInitDisplayMode (toBitfield marshalDisplayMode transformedModes)++handleMultisampling :: [Int] -> DisplayMode -> ([Int], DisplayMode)+handleMultisampling spps (WithSamplesPerPixel spp) = (spp : spps, Multisampling)+handleMultisampling spps mode                      = (spps, mode)++toBitfield :: (Num b, Bits b) => (a -> b) -> [a] -> b+toBitfield marshal = foldl (.|.) 0 . map marshal++-- | Contains 'True' if the /current display mode/ is supported, 'False'+-- otherwise.++displayModePossible :: GettableStateVar Bool+displayModePossible =+   makeGettableStateVar $ simpleGet (/= 0) glut_DISPLAY_MODE_POSSIBLE++--------------------------------------------------------------------------------++samplesPerPixel :: StateVar Int+samplesPerPixel = makeStateVar getSamplesPerPixel setSamplesPerPixel++getSamplesPerPixel :: IO Int+getSamplesPerPixel = do+   m <- multisamplingSupported+   if m+      then simpleGet fromIntegral (fromIntegral glut_MULTISAMPLE)+      else return defaultSamplesPerPixels++defaultSamplesPerPixels :: Int+defaultSamplesPerPixels = 4++setSamplesPerPixel :: Int -> IO ()+setSamplesPerPixel spp = do+   m <- multisamplingSupported+   when m $+      glutSetOption (fromIntegral glut_MULTISAMPLE) (fromIntegral spp)++multisamplingSupported :: IO Bool+multisamplingSupported = isKnown "glutGetModeValues"+   where isKnown = fmap (/= nullFunPtr) . getAPIEntryInternal++--------------------------------------------------------------------------------++-- | Capabilities for 'initialDisplayCapabilities', most of them are extensions+-- of the constructors of 'DisplayMode'.++data DisplayCapability+   = DisplayRGBA  -- ^ Number of bits of red, green, blue, and alpha in the RGBA+                  --   color buffer. Default is \"'IsAtLeast' @1@\" for red,+                  --   green, blue, and alpha capabilities, and \"'IsEqualTo'+                  --   @1@\" for the RGBA color model capability.+   | DisplayRGB   -- ^ Number of bits of red, green, and blue in the RGBA color+                  --   buffer and zero bits of alpha color buffer precision.+                  --   Default is \"'IsAtLeast' @1@\" for the red, green, and+                  --   blue capabilities, and \"'IsNotLessThan' @0@\" for alpha+                  --   capability, and \"'IsEqualTo' @1@\" for the RGBA color+                  --   model capability.+   | DisplayRed   -- ^ Red color buffer precision in bits. Default is+                  --   \"'IsAtLeast' @1@\".+   | DisplayGreen -- ^ Green color buffer precision in bits. Default is+                  --   \"'IsAtLeast' @1@\".+   | DisplayBlue  -- ^ Blue color buffer precision in bits. Default is+                  --   \"'IsAtLeast' @1@\".+   | DisplayIndex -- ^ Boolean if the color model is color index or not. True is+                  --   color index. Default is \"'IsAtLeast' @1@\".+   | DisplayBuffer -- ^ Number of bits in the color index color buffer. Default+                  --   is \"'IsAtLeast' @1@\".+   | DisplaySingle -- ^ Boolean indicate the color buffer is single buffered.+                  --   Default is \"'IsEqualTo' @1@\".+   | DisplayDouble -- ^ Boolean indicating if the color buffer is double+                  --   buffered. Default is \"'IsEqualTo' @1@\".+   | DisplayAccA  -- ^ Red, green, blue, and alpha accumulation buffer precision+                  --   in  bits. Default is \"'IsAtLeast' @1@\" for red, green,+                  --   blue, and alpha capabilities.+   | DisplayAcc   -- ^ Red, green, and green accumulation buffer precision in+                  --   bits and zero bits of alpha accumulation buffer precision.+                  --   Default is \"'IsAtLeast' @1@\" for red, green, and blue+                  --   capabilities, and \"'IsNotLessThan' @0@\" for the alpha+                  --   capability.+   | DisplayAlpha -- ^ Alpha color buffer precision in bits. Default is+                  --   \"'IsAtLeast' @1@\".+   | DisplayDepth -- ^ Number of bits of precsion in the depth buffer. Default+                  --   is \"'IsAtLeast' @12@\".+   | DisplayStencil -- ^ Number of bits in the stencil buffer. Default is+                  --   \"'IsNotLessThan' @1@\".+   | DisplaySamples -- ^ Indicates the number of multisamples to use based on+                  --   GLX\'s @SGIS_multisample@ extension (for antialiasing).+                  --   Default is \"'IsNotGreaterThan' @4@\". This default means+                  --   that a GLUT application can request multisampling if+                  --   available by simply specifying \"'With' 'DisplaySamples'\".+   | DisplayStereo -- ^ Boolean indicating the color buffer is supports+                  --   OpenGL-style stereo. Default is \"'IsEqualTo' @1@\".+   | DisplayLuminance -- ^ Number of bits of red in the RGBA and zero bits of green,+                  --   blue (alpha not specified) of color buffer precision.+                  --   Default is \"'IsAtLeast' @1@\" for the red capabilitis,+                  --   and \"'IsEqualTo' @0@\" for the green and blue+                  --   capabilities, and \"'IsEqualTo' @1@\" for the RGBA color+                  --   model capability, and, for X11, \"'IsEqualTo' @1@\" for+                  --   the 'DisplayXStaticGray' capability. SGI InfiniteReality (and+                  --   other future machines) support a 16-bit luminance (single+                  --   channel) display mode (an additional 16-bit alpha channel+                  --   can also be requested). The red channel maps to gray+                  --   scale and green and blue channels are not available. A+                  --   16-bit precision luminance display mode is often+                  --   appropriate for medical imaging applications. Do not+                  --   expect many machines to support extended precision+                  --   luminance display modes.+   | DisplayAux   -- ^ (/freeglut only/) Number of auxiliary buffers. Default is+                  --   \"'IsEqualTo' @1@\".+   | DisplayNum   -- ^ A special capability name indicating where the value+                  --   represents the Nth frame buffer configuration matching+                  --   the description string. When not specified,+                  --   'initialDisplayCapabilities' also uses the first+                  --   (best matching) configuration. 'Num' requires a relation+                  --   and numeric value.+   | DisplayConformant -- ^ Boolean indicating if the frame buffer configuration is+                  --   conformant or not. Conformance information is based on+                  --   GLX\'s @EXT_visual_rating@ extension if supported. If the+                  --   extension is not supported, all visuals are assumed+                  --   conformant. Default is \"'IsEqualTo' @1@\".+   | DisplaySlow  -- ^ Boolean indicating if the frame buffer configuration is+                  --   slow or not. Slowness information is based on GLX\'s+                  --   @EXT_visual_rating@ extension if supported. If the+                  --   extension is not supported, all visuals are assumed fast.+                  --   Note that slowness is a relative designation relative to+                  --   other frame buffer configurations available. The intent+                  --   of the slow capability is to help programs avoid frame+                  --   buffer configurations that are slower (but perhaps higher+                  --   precision) for the current machine. Default is+                  --   \"'IsAtLeast' @0@\". This default means that slow visuals+                  --   are used in preference to fast visuals, but fast visuals+                  --   will still be allowed.+   | DisplayWin32PFD -- ^ Only recognized on GLUT implementations for Win32, this+                  --   capability name matches the Win32 Pixel Format Descriptor+                  --   by number. 'DisplayWin32PFD' can only be used with 'Where'.+   | DisplayXVisual -- ^ Only recongized on GLUT implementations for the X Window+                  --   System, this capability name matches the X visual ID by+                  --   number. 'DisplayXVisual' requires a relation and numeric value.+   | DisplayXStaticGray -- ^ Only recongized on GLUT implementations for the X Window+                  --   System, boolean indicating if the frame buffer+                  --   configuration\'s X visual is of type @StaticGray@.+                  --   Default is \"'IsEqualTo' @1@\".+   | DisplayXGrayScale -- ^ Only recongized on GLUT implementations for the X Window+                  --   System, boolean indicating if the frame buffer+                  --   configuration\'s X visual is of type @GrayScale@. Default+                  --   is \"'IsEqualTo' @1@\".+   | DisplayXStaticColor -- ^ Only recongized on GLUT implementations for the X Window+                  --   System, boolean indicating if the frame buffer+                  --   configuration\'s X visual is of type @StaticColor@.+                  --   Default is \"'IsEqualTo' @1@\".+   | DisplayXPseudoColor -- ^ Only recongized on GLUT implementations for the X Window+                  --   System, boolean indicating if the frame buffer+                  --   configuration\'s X visual is of type @PsuedoColor@.+                  --   Default is \"'IsEqualTo' @1@\".+   | DisplayXTrueColor -- ^ Only recongized on GLUT implementations for the X Window+                  --   System, boolean indicating if the frame buffer+                  --   configuration\'s X visual is of type @TrueColor@. Default+                  --   is \"'IsEqualTo' @1@\".+   | DisplayXDirectColor -- ^ Only recongized on GLUT implementations for the X Window+                  --   System, boolean indicating if the frame buffer+                  --   configuration\'s X visual is of type @DirectColor@.+                  --   Default is \"'IsEqualTo' @1@\".+   deriving ( Eq, Ord, Show )++displayCapabilityToString :: DisplayCapability -> String+displayCapabilityToString x = case x of+   DisplayRGBA         -> "rgba"+   DisplayRGB          -> "rgb"+   DisplayRed          -> "red"+   DisplayGreen        -> "green"+   DisplayBlue         -> "blue"+   DisplayIndex        -> "index"+   DisplayBuffer       -> "buffer"+   DisplaySingle       -> "single"+   DisplayDouble       -> "double"+   DisplayAccA         -> "acca"+   DisplayAcc          -> "acc"+   DisplayAlpha        -> "alpha"+   DisplayDepth        -> "depth"+   DisplayStencil      -> "stencil"+   DisplaySamples      -> "samples"+   DisplayStereo       -> "stereo"+   DisplayLuminance    -> "luminance"+   DisplayAux          -> "aux"+   DisplayNum          -> "num"+   DisplayConformant   -> "conformant"+   DisplaySlow         -> "slow"+   DisplayWin32PFD     -> "win32pfd"+   DisplayXVisual      -> "xvisual"+   DisplayXStaticGray  -> "xstaticgray"+   DisplayXGrayScale   -> "xgrayscale"+   DisplayXStaticColor -> "xstaticcolor"+   DisplayXPseudoColor -> "xpseudocolor"+   DisplayXTrueColor   -> "xtruecolor"+   DisplayXDirectColor -> "xdirectcolor"++-- | A single capability description for 'initialDisplayCapabilities'.++data DisplayCapabilityDescription+   = Where DisplayCapability Relation Int+     -- ^ A description of a capability with a specific relation to a numeric+     --   value.+   | With  DisplayCapability+     -- ^ When the relation and numeric value are not specified, each capability+     --   has a different default, see the different constructors of+     --   'DisplayCapability'.+   deriving ( Eq, Ord, Show )++displayCapabilityDescriptionToString ::  DisplayCapabilityDescription -> String+displayCapabilityDescriptionToString (Where c r i) =+   displayCapabilityToString c ++ relationToString r ++ show i+displayCapabilityDescriptionToString (With c) = displayCapabilityToString c++-- | Controls the /initial display mode/ used when creating top-level windows,+-- subwindows, and overlays to determine the OpenGL display mode for the+-- to-be-created window or overlay. It is described by a list of zero or more+-- capability descriptions, which are translated into a set of criteria used to+-- select the appropriate frame buffer configuration. The criteria are matched+-- in strict left to right order of precdence. That is, the first specified+-- criterion (leftmost) takes precedence over the later criteria for non-exact+-- criteria ('IsGreaterThan', 'IsLessThan', etc.). Exact criteria ('IsEqualTo',+-- 'IsNotEqualTo') must match exactly so precedence is not relevant.+--+-- Unspecified capability descriptions will result in unspecified criteria being+-- generated. These unspecified criteria help 'initialDisplayCapabilities'+-- behave sensibly with terse display mode descriptions.+--+-- Here is an example using 'initialDisplayCapabilities':+--+-- @+--    initialDisplayCapabilities $= [ With  DisplayRGB,+--                                    Where DisplayDepth IsAtLeast 16,+--                                    With  DisplaySamples,+--                                    Where DisplayStencil IsNotLessThan 2,+--                                    With  DisplayDouble ]+-- @+--+-- The above call requests a window with an RGBA color model (but requesting+-- no bits of alpha), a depth buffer with at least 16 bits of precision but+-- preferring more, multisampling if available, at least 2 bits of stencil+-- (favoring less stencil to more as long as 2 bits are available), and double+-- buffering.++initialDisplayCapabilities :: SettableStateVar [DisplayCapabilityDescription]+initialDisplayCapabilities =+   makeSettableStateVar $ \caps ->+      withCString+         (concat . intersperse " " . map displayCapabilityDescriptionToString $+          caps)+         glutInitDisplayString++-----------------------------------------------------------------------------++-- | How rendering context for new windows are created.++data RenderingContext+   = -- | Create a new context via @glXCreateContext@ or @wglCreateContext@+     --   (default).+     CreateNewContext+   | -- | Re-use the current rendering context.+     UseCurrentContext+   deriving ( Eq, Ord, Show )++marshalRenderingContext :: RenderingContext -> CInt+marshalRenderingContext CreateNewContext  = glut_CREATE_NEW_CONTEXT+marshalRenderingContext UseCurrentContext = glut_USE_CURRENT_CONTEXT++unmarshalRenderingContext :: CInt -> RenderingContext+unmarshalRenderingContext r+   | r == glut_CREATE_NEW_CONTEXT  = CreateNewContext+   | r == glut_USE_CURRENT_CONTEXT = UseCurrentContext+   | otherwise = error "unmarshalRenderingContext"++-----------------------------------------------------------------------------++-- | (/freeglut only/) Controls the creation of rendering contexts for new+-- windows.++renderingContext :: StateVar RenderingContext+renderingContext =+   makeStateVar+      (simpleGet unmarshalRenderingContext glut_RENDERING_CONTEXT)+      (glutSetOption glut_RENDERING_CONTEXT . marshalRenderingContext)++-----------------------------------------------------------------------------++-- | The kind of GLX rendering context used. Direct rendering provides a+-- performance advantage in some implementations. However, direct rendering+-- contexts cannot be shared outside a single process, and they may be unable+-- to render to GLX pixmaps.++data DirectRendering+   = -- | Rendering is always done through the X server. This corresponds to+     -- the command line argument @-indirect@, see 'initialize'.+     ForceIndirectContext+   | -- | Try to use direct rendering, silently using indirect rendering if this+     -- is not possible.+     AllowDirectContext+   | -- | Try to use direct rendering, issue a warning and use indirect+     -- rendering if this is not possible.+     TryDirectContext+   | -- | Try to use direct rendering, issue an error and terminate the program+     -- if this is not possible.This corresponds to the command line argument+     -- @-direct@, see 'initialize'.+     ForceDirectContext+   deriving ( Eq, Ord, Show )++marshalDirectRendering :: DirectRendering -> CInt+marshalDirectRendering x = case x of+   ForceIndirectContext -> glut_FORCE_INDIRECT_CONTEXT+   AllowDirectContext -> glut_ALLOW_DIRECT_CONTEXT+   TryDirectContext -> glut_TRY_DIRECT_CONTEXT+   ForceDirectContext -> glut_FORCE_DIRECT_CONTEXT++unmarshalDirectRendering :: CInt -> DirectRendering+unmarshalDirectRendering x+   | x == glut_FORCE_INDIRECT_CONTEXT = ForceIndirectContext+   | x == glut_ALLOW_DIRECT_CONTEXT = AllowDirectContext+   | x == glut_TRY_DIRECT_CONTEXT = TryDirectContext+   | x == glut_FORCE_DIRECT_CONTEXT = ForceDirectContext+   | otherwise = error ("unmarshalDirectRendering: illegal value " ++ show x)++-----------------------------------------------------------------------------++-- | (/freeglut on X11 only/) Controls which kind of rendering context is+-- created when a new one is required.++directRendering :: StateVar DirectRendering+directRendering =+   makeStateVar+      (simpleGet unmarshalDirectRendering glut_DIRECT_RENDERING)+      (glutSetOption glut_DIRECT_RENDERING . marshalDirectRendering)++-----------------------------------------------------------------------------++-- | (/freeglut only/) Controls the API major\/minor version of the OpenGL+-- context. If a version less than or equal to 2.1 is requested, the context+-- returned may implement any version no less than that requested and no+-- greater than 2.1. If version 3.0 is requested, the context returned must+-- implement exactly version 3.0. Versioning behavior once GL versions beyond+-- 3.0 are defined will be defined by an amendment to the OpenGL specification+-- to define dependencies on such GL versions.+--+-- 'Graphics.Rendering.OpenGL.GL.StringQueries.glVersion' and+-- 'Graphics.Rendering.OpenGL.GL.StringQueries.majorMinor' will return the+-- actual version supported by a context.+--+-- The default context version is (1, 0), which will typically return an+-- OpenGL 2.1 context, if one is available.++initialContextVersion :: StateVar (Int, Int)+initialContextVersion = makeStateVar getContextVersion setContextVersion++getContextVersion :: IO (Int, Int)+getContextVersion = do+   major <- simpleGet fromIntegral glut_INIT_MAJOR_VERSION+   minor <- simpleGet fromIntegral glut_INIT_MINOR_VERSION+   return (major, minor)++setContextVersion :: (Int, Int) -> IO ()+setContextVersion (major, minor) =+   glutInitContextVersion (fromIntegral major) (fromIntegral minor)++-----------------------------------------------------------------------------++-- | A flag affecting the rendering context to create, used in conjunction+-- with 'initialContextFlags'.++data ContextFlag+   = -- | Debug contexts are intended for use during application development,+     -- and provide additional runtime checking, validation, and logging+     -- functionality while possibly incurring performance penalties. The+     -- additional functionality provided by debug contexts may vary according+     -- to the implementation. In some cases a debug context may be identical+     -- to a non-debug context.+     DebugContext+   | -- | Forward-compatible contexts are defined only for OpenGL versions 3.0+     -- and later. They must not support functionality marked as /deprecated/+     -- by that version of the API, while a non-forward-compatible context must+     -- support all functionality in that version, deprecated or not.+     ForwardCompatibleContext+   deriving ( Eq, Ord, Show )++marshalContextFlag :: ContextFlag -> CInt+marshalContextFlag x = case x of+   DebugContext -> glut_DEBUG+   ForwardCompatibleContext -> glut_FORWARD_COMPATIBLE++-----------------------------------------------------------------------------++-- | (/freeglut only/) Controls the set of flags for the rendering context.++initialContextFlags :: StateVar [ContextFlag]+initialContextFlags = makeStateVar getContextFlags setContextFlags++getContextFlags :: IO [ContextFlag]+getContextFlags = simpleGet i2cfs glut_INIT_FLAGS++i2cfs :: CInt -> [ContextFlag]+i2cfs bitfield =+   [ c | c <- [ DebugContext, ForwardCompatibleContext ]+       , (fromIntegral bitfield .&. marshalContextFlag c) /= 0 ]++setContextFlags :: [ContextFlag] -> IO ()+setContextFlags = glutInitContextFlags . toBitfield marshalContextFlag+++-----------------------------------------------------------------------------++-- | An OpenGL API profile, affecting the rendering context to create, used+-- in conjunction with 'initialContextProfile'.++data ContextProfile+   = -- | The OpenGL /core/ profile, which all OpenGL 3.2 implementations+     -- are required to support.+      CoreProfile+   | -- | The OpenGL /compatibility/ profile, which is optional for OpenGL+     -- 3.2 implementations.+     CompatibilityProfile+   deriving ( Eq, Ord, Show )++marshalContextProfile :: ContextProfile -> CInt+marshalContextProfile x = case x of+   CoreProfile -> glut_CORE_PROFILE+   CompatibilityProfile -> glut_COMPATIBILITY_PROFILE++-----------------------------------------------------------------------------++-- | (/freeglut only/) Controls the set of profiles for the rendering context.++initialContextProfile :: StateVar [ContextProfile]+initialContextProfile = makeStateVar getContextProfiles setContextProfiles++getContextProfiles :: IO [ContextProfile]+getContextProfiles = simpleGet i2cps glut_INIT_PROFILE++i2cps :: CInt -> [ContextProfile]+i2cps bitfield =+   [ c | c <- [ CoreProfile, CompatibilityProfile ]+       , (fromIntegral bitfield .&. marshalContextProfile c) /= 0 ]++setContextProfiles :: [ContextProfile] -> IO ()+setContextProfiles = glutInitContextProfile . toBitfield marshalContextProfile
+ src/Graphics/UI/GLUT/Menu.hs view
@@ -0,0 +1,262 @@+{-# OPTIONS_GHC -fno-cse #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Menu+-- Copyright   :  (c) Sven Panne 2002-2013+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- Stability   :  stable+-- Portability :  portable+--+-- GLUT supports simple cascading pop-up menus. They are designed to let a user+-- select various modes within a program. The functionality is simple and+-- minimalistic and is meant to be that way. Do not mistake GLUT\'s pop-up menu+-- facility with an attempt to create a full-featured user interface.+--+--------------------------------------------------------------------------------++module Graphics.UI.GLUT.Menu (+   Menu(..), MenuItem(..), MenuCallback, attachMenu,+   numMenuItems+) where++import Data.Array+import Data.IORef+import qualified Data.Map as Map+import Control.Monad+import Data.Map ( Map )+import Foreign.C.String+import Foreign.C.Types+import Foreign.Ptr+import Graphics.Rendering.OpenGL+import Graphics.UI.GLUT.Callbacks.Registration+import Graphics.UI.GLUT.QueryUtils+import Graphics.UI.GLUT.Raw+import Graphics.UI.GLUT.Types++--------------------------------------------------------------------------------++-- | A menu is simply a list of menu items, possibly with an associated font.+data Menu+   = Menu [MenuItem]+   | MenuWithFont BitmapFont [MenuItem]++menuFont :: Menu -> Maybe BitmapFont+menuFont (Menu _) = Nothing+menuFont (MenuWithFont font _) = Just font++menuItems :: Menu -> [MenuItem]+menuItems (Menu items) = items+menuItems (MenuWithFont _ items) = items++-- | A single item within a menu can either be a plain menu entry or a sub-menu+-- entry, allowing for arbitrarily deep nested menus.+data MenuItem+   = MenuEntry String MenuCallback -- ^ A plain menu entry with an associated+                                   --   callback, which is triggered when the+                                   --   user selects the entry+   | SubMenu   String Menu         -- ^ A sub-menu, which is cascaded when the+                                   --   user selects the entry, allowing+                                   --   sub-menu entries to be selected++type MenuCallback = IO ()++-- | Create a new pop-up menu for the /current window,/ attaching it to the+-- given mouse button. A previously attached menu (if any), is detached before+-- and won\'t receive callbacks anymore.+--+-- It is illegal to call 'attachMenu' while any (sub-)menu is in use, i.e.+-- popped up.+--+-- /X Implementation Notes:/ If available, GLUT for X will take advantage of+-- overlay planes for implementing pop-up menus. The use of overlay planes can+-- eliminate display callbacks when pop-up menus are deactivated. The+-- @SERVER_OVERLAY_VISUALS@ convention is used to determine if overlay visuals+-- are available.++attachMenu :: MouseButton -> Menu -> IO ()+attachMenu mouseButton menu = do+   win <- getCurrentWindow "attachMenu"+   let hook = MenuHook win mouseButton+   detachMenu hook+   unless (null (menuItems menu)) $ do+      (_, destructor) <- traverseMenu menu+      addToMenuTable hook destructor+      attachMenu_ mouseButton++detachMenu :: MenuHook -> IO ()+detachMenu hook@(MenuHook _ mouseButton) = do+   maybeDestructor <- lookupInMenuTable hook+   case maybeDestructor of+      Nothing         -> return ()+      Just destructor -> do detachMenu_ mouseButton+                            destructor+   deleteFromMenuTable hook++traverseMenu :: Menu -> IO (MenuID, Destructor)+traverseMenu menu = do+   let items = menuItems menu+       callbackArray = listArray (1, length items) (map makeCallback items)+   cb <- makeMenuFunc (\i -> callbackArray ! (fromIntegral i))+   menuID <- glutCreateMenu cb+   maybe (return ()) (setMenuFont menuID) (menuFont menu)+   destructors <- zipWithM addMenuItem items [1..]+   let destructor = do sequence_ destructors+                       glutDestroyMenu menuID+                       freeHaskellFunPtr cb+   return (menuID, destructor)++makeCallback :: MenuItem -> MenuCallback+makeCallback (MenuEntry _ cb) = cb+makeCallback _ = error "shouldn't receive a callback for submenus"++addMenuItem :: MenuItem -> Value -> IO Destructor+addMenuItem (MenuEntry s _) v = do+   addMenuEntry s v+   return $ glutRemoveMenuItem 1+addMenuItem (SubMenu s m) _ = do+   (menuID, destructor) <- saveExcursion (traverseMenu m)+   addSubMenu s menuID+   return $ do glutRemoveMenuItem 1+               destructor++-- Perform an action, saving/restoring the current menu around it+saveExcursion :: IO a -> IO a+saveExcursion act = do+   menuID <- get currentMenu+   returnValue <- act+   when (isRealMenu menuID) $+      currentMenu $= menuID+   return returnValue++--------------------------------------------------------------------------------+-- This seems to be a common Haskell hack nowadays: A plain old global variable+-- with an associated mutator. Perhaps some language/library support is needed?++{-# NOINLINE theMenuTable #-}+theMenuTable :: IORef MenuTable+theMenuTable = unsafePerformIO (newIORef emptyMenuTable)++getMenuTable :: IO MenuTable+getMenuTable = readIORef theMenuTable++modifyMenuTable :: (MenuTable -> MenuTable) -> IO ()+modifyMenuTable = modifyIORef theMenuTable++--------------------------------------------------------------------------------+-- To facilitate cleanup, we have to keep track how to destroy menus which are+-- currently attached in a window to a mouse button.++data MenuHook = MenuHook Window MouseButton+   deriving ( Eq, Ord )++type Destructor = IO ()++type MenuTable = Map MenuHook Destructor++emptyMenuTable :: MenuTable+emptyMenuTable = Map.empty++lookupInMenuTable :: MenuHook -> IO (Maybe Destructor)+lookupInMenuTable callbackID =+   fmap (Map.lookup callbackID) getMenuTable++deleteFromMenuTable :: MenuHook -> IO ()+deleteFromMenuTable callbackID =+   modifyMenuTable (Map.delete callbackID)++addToMenuTable :: MenuHook -> Destructor -> IO ()+addToMenuTable callbackID funPtr =+   modifyMenuTable (Map.insert callbackID funPtr)++--------------------------------------------------------------------------------++type MenuID = CInt+type Value  = CInt++--------------------------------------------------------------------------------++-- | Controls the /current menu./ If no menus exist or the previous /current+-- menu/ was destroyed, a pseudo menu is returned.++currentMenu :: StateVar MenuID+currentMenu = makeStateVar glutGetMenu glutSetMenu++-- | Returns 'True' if the given menu identifier refers to a real menu, not+-- a pseudo one.++isRealMenu :: MenuID -> Bool+isRealMenu = (/= 0)++--------------------------------------------------------------------------------++-- | Add a menu entry to the bottom of the /current menu./ The given string will+-- be displayed for the newly added menu entry. If the menu entry is selected by+-- the user, the menu\'s callback will be called passing the given value as the+-- callback\'s parameter.++addMenuEntry :: String -> Value -> IO ()+addMenuEntry name value = withCString name $ \n -> glutAddMenuEntry n value++-- | Add a sub-menu trigger to the bottom of the /current menu./ The given+-- string will be displayed for the newly added sub-menu trigger. If the+-- sub-menu trigger is entered, the sub-menu specified by the given menu+-- identifier will be cascaded, allowing sub-menu menu items to be selected.++addSubMenu :: String -> MenuID -> IO ()+addSubMenu name menuID = withCString name $ \n -> glutAddSubMenu n menuID++--------------------------------------------------------------------------------++{- UNUSED+-- | Change the specified menu entry in the /current menu/ into a menu entry.+-- The given position determines which menu item should be changed and must be+-- between 1 (the topmost menu item) and+-- 'Graphics.UI.GLUT.State.getNumMenuItems' inclusive. The menu item to change+-- does not have to be a menu entry already. The given string will be displayed+-- for the newly changed menu entry. The given value will be returned to the+-- menu\'s callback if this menu entry is selected.++foreign import CALLCONV unsafe "glutChangeToMenuEntry" glutChangeToMenuEntry ::+   Item -> CString -> Value -> IO ()++-- | Change the specified menu item in the /current menu/ into a sub-menu+-- trigger. The  given position determines which menu item should be changed and+-- must be between 1 and 'Graphics.UI.GLUT.State.getNumMenuItems' inclusive. The+-- menu item to change does not have to be a sub-menu trigger already. The+-- given name will be displayed for the newly changed sub-menu trigger. The+-- given menu identifier names the sub-menu to cascade from the newly added+-- sub-menu trigger.++foreign import CALLCONV unsafe "glutChangeToSubMenu" glutChangeToSubMenu ::+   Item -> CString -> MenuID -> IO ()+-}++--------------------------------------------------------------------------------++-- | Attach a mouse button for the /current window/ to the identifier of the+-- /current menu./ By attaching a menu identifier to a button, the named menu+-- will be popped up when the user presses the specified button. Note that the+-- menu is attached to the button by identifier, not by reference.++attachMenu_ :: MouseButton -> IO ()+attachMenu_ = glutAttachMenu . marshalMouseButton++-- | Detach an attached mouse button from the /current window./++detachMenu_ :: MouseButton -> IO ()+detachMenu_ = glutDetachMenu . marshalMouseButton++--------------------------------------------------------------------------------++-- | Contains the number of menu items in the /current menu./++numMenuItems :: GettableStateVar Int+numMenuItems = makeGettableStateVar $ simpleGet fromIntegral glut_MENU_NUM_ITEMS++--------------------------------------------------------------------------------++setMenuFont :: MenuID -> BitmapFont -> IO ()+setMenuFont menuID font = glutSetMenuFont menuID =<< marshalBitmapFont font
+ src/Graphics/UI/GLUT/Objects.hs view
@@ -0,0 +1,180 @@+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Objects+-- Copyright   :  (c) Sven Panne 2002-2013+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- Stability   :  stable+-- Portability :  portable+--+-- GLUT includes a number of routines for generating easily recognizable 3D+-- geometric objects. These routines reflect functionality available in the+-- @aux@ toolkit described in the /OpenGL Programmer\'s Guide/ and are included+-- in GLUT to allow the construction of simple GLUT programs that render+-- recognizable objects. These routines can be implemented as pure OpenGL+-- rendering routines. The routines do not generate display lists for the+-- objects they create. The routines generate normals appropriate for lighting+-- but do not generate texture coordinates (except for the solid teapot, teacup+-- and teaspoon). If VBOs should be used instead of the fixed function pipeline,+-- specify at least one of the attribute locations+-- 'Graphics.UI.GLUT.State.vertexAttribCoord3' or+-- 'Graphics.UI.GLUT.State.vertexAttribNormal'.+--+--------------------------------------------------------------------------------++module Graphics.UI.GLUT.Objects (+   -- * Rendering flavour+   Flavour(..),++   -- * Object description+   Object(..),++   -- * Type synonyms+   Sides, Rings, NumLevels,++   -- * Rendering+   renderObject+) where++import Foreign.C.Types+import Foreign.Marshal.Utils+import Foreign.Ptr+import Graphics.Rendering.OpenGL+import Graphics.UI.GLUT.Raw++--------------------------------------------------------------------------------++-- | Flavour of object rendering++data Flavour+   = -- | Object is rendered as a solid with shading and surface normals.+     Solid+   | -- | Object is rendered as a wireframe without surface normals.+     Wireframe+   deriving ( Eq, Ord, Show )++--------------------------------------------------------------------------------++-- | GLUT offers five types of objects:+--+-- *  The five Platonic solids, see+--    <http://mathworld.wolfram.com/PlatonicSolid.html>.+--+-- * A rhombic dodecahedron, see+--   <http://mathworld.wolfram.com/RhombicDodecahedron.html>.+--+-- * Approximations to rounded objects.+--+-- * The classic teaset modeled by Martin Newell in 1975. Both surface normals+--   and texture coordinates for the teaset are generated.+--+-- * A Sierpinski sponge, see+--   <http://mathworld.wolfram.com/Tetrix.html>.++data Object+   = -- | A cube centered at the modeling coordinates origin with sides of the+     --   given length.+     Cube Height+   | -- | A dodecahedron (12-sided regular solid) centered at the modeling+     --   coordinates origin with a radius of @sqrt 3@.+     Dodecahedron+   | -- | A icosahedron (20-sided regular solid) centered at the modeling+     --   coordinates origin with a radius of 1.0.+     Icosahedron+   | -- | Render a solid octahedron (8-sided regular solid) centered at the+     --   modeling coordinates origin with a radius of 1.0.+     Octahedron+   | -- | Render a solid tetrahedron (4-sided regular solid) centered at the+     --   modeling coordinates origin with a radius of @sqrt 3@.+     Tetrahedron+   | -- | (/freeglut only/) A rhombic dodecahedron whose corners are at most a+     -- distance of one from the origin. The rhombic dodecahedron has faces+     -- which are identical rhombi, but which have some vertices at which three+     -- faces meet and some vertices at which four faces meet. The length of+     -- each side is @(sqrt 3)\/2@. Vertices at which four faces meet are found+     -- at @(0, 0, +\/-1)@ and @(+\/-(sqrt 2)\/2, +\/-(sqrt 2)\/2, 0)@.+     RhombicDodecahedron+   | -- | A sphere centered at the modeling coordinates origin of the specified+     --   radius. The sphere is subdivided around the Z axis into slices+     --   (similar to lines of longitude) and along the Z axis into stacks+     --   (similar to lines of latitude).+     Sphere' Radius Slices Stacks+   | -- | A cone oriented along the Z axis. The base of the cone is placed at Z+     --   = 0, and the top at Z = the given height. The cone is subdivided+     --   around the Z axis into slices, and along the Z axis into stacks.+     Cone Radius Height Slices Stacks+   | -- |(/freeglut only/) A cylinder oriented along the Z axis. The base of the+     --  cylinder is placed at Z = 0, and the top at Z = the given height. The+     --  cylinder is subdivided around the Z axis into slices, and along the Z+     -- axis into stacks.+     Cylinder' Radius Height Slices Stacks+   | -- | A torus (doughnut) centered at the modeling coordinates origin+     -- whose axis is aligned with the Z axis. The torus is described by its+     -- inner and outer radius, the number of sides for each radial section,+     -- and the number of radial divisions (rings).+     Torus Radius Radius Sides Rings+   | -- | A teapot with a given relative size.+     Teapot Height+   | -- |(/freeglut only/) A teacup with a given relative size.+     Teacup Height+   | -- |(/freeglut only/) A teaspoon with a given relative size.+     Teaspoon Height+   | -- |(/freeglut only/) A Sierpinski sponge of a given level, where a level+     -- 0 sponge is the same as a 'Tetrahedron'.+     SierpinskiSponge NumLevels+   deriving ( Eq, Ord, Show )++--------------------------------------------------------------------------------++type Sides     = GLint+type Rings     = GLint+type NumLevels = GLint++--------------------------------------------------------------------------------++-- | Render an object in the given flavour.++renderObject :: Flavour -> Object -> IO ()+renderObject Solid     (Cube h)             = glutSolidCube h+renderObject Wireframe (Cube h)             = glutWireCube  h+renderObject Solid     Dodecahedron         = glutSolidDodecahedron+renderObject Wireframe Dodecahedron         = glutWireDodecahedron+renderObject Solid     Icosahedron          = glutSolidIcosahedron+renderObject Wireframe Icosahedron          = glutWireIcosahedron+renderObject Solid     Octahedron           = glutSolidOctahedron+renderObject Wireframe Octahedron           = glutWireOctahedron+renderObject Solid     Tetrahedron          = glutSolidTetrahedron+renderObject Wireframe Tetrahedron          = glutWireTetrahedron+renderObject Solid     RhombicDodecahedron  = glutSolidRhombicDodecahedron+renderObject Wireframe RhombicDodecahedron  = glutWireRhombicDodecahedron+renderObject Solid     (Sphere' r s t)      = glutSolidSphere r s t+renderObject Wireframe (Sphere' r s t)      = glutWireSphere  r s t+renderObject Solid     (Cone r h s t)       = glutSolidCone r h s t+renderObject Wireframe (Cone r h s t)       = glutWireCone  r h s t+renderObject Solid     (Cylinder' r h s t)  = glutSolidCylinder r h s t+renderObject Wireframe (Cylinder' r h s t)  = glutWireCylinder r h s t+renderObject Solid     (Torus i o s r)      = glutSolidTorus i o s r+renderObject Wireframe (Torus i o s r)      = glutWireTorus  i o s r+renderObject Solid     (Teapot h)           = glutSolidTeapot h+renderObject Wireframe (Teapot h)           = glutWireTeapot  h+renderObject Solid     (Teacup h)           = glutSolidTeacup h+renderObject Wireframe (Teacup h)           = glutWireTeacup  h+renderObject Solid     (Teaspoon h)         = glutSolidTeaspoon h+renderObject Wireframe (Teaspoon h)         = glutWireTeaspoon  h+renderObject Solid     (SierpinskiSponge n) = solidSierpinskiSponge n+renderObject Wireframe (SierpinskiSponge n) = wireSierpinskiSponge n++--------------------------------------------------------------------------------++solidSierpinskiSponge :: NumLevels -> IO ()+solidSierpinskiSponge = sierpinskiSponge glutSolidSierpinskiSponge++wireSierpinskiSponge :: NumLevels -> IO ()+wireSierpinskiSponge = sierpinskiSponge glutWireSierpinskiSponge++-- for consistency, we hide the offset and scale on the Haskell side+sierpinskiSponge :: (CInt -> Ptr GLdouble -> Height -> IO ()) -> NumLevels -> IO ()+sierpinskiSponge f n =+   with (Vertex3 0 0 0) $ \offsetBuf ->+      f (fromIntegral n) ((castPtr :: Ptr (Vertex3 GLdouble) -> Ptr GLdouble) offsetBuf) 1
+ src/Graphics/UI/GLUT/Overlay.hs view
@@ -0,0 +1,168 @@+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Overlay+-- Copyright   :  (c) Sven Panne 2002-2013+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- Stability   :  stable+-- Portability :  portable+--+-- When  overlay hardware is available, GLUT provides a set of routines for+-- establishing, using, and removing an overlay for GLUT windows. When an+-- overlay is established, a separate OpenGL context is also established. A+-- window\'s overlay OpenGL state is kept distinct from the normal planes\'+-- OpenGL state.+--+--------------------------------------------------------------------------------++module Graphics.UI.GLUT.Overlay (+   -- * Overlay creation and destruction+   hasOverlay, overlayPossible,++   -- * Showing and hiding an overlay+   overlayVisible,++   -- * Changing the /layer in use/+   Layer(..), layerInUse,++   -- * Re-displaying+   postOverlayRedisplay+) where++import Graphics.Rendering.OpenGL ( GLenum, StateVar, makeStateVar+                                 , GettableStateVar, makeGettableStateVar+                                 , SettableStateVar, makeSettableStateVar )+import Graphics.UI.GLUT.QueryUtils+import Graphics.UI.GLUT.Raw+import Graphics.UI.GLUT.Types++--------------------------------------------------------------------------------++-- | Controls the overlay for the /current window/. The requested display mode+-- for the overlay is determined by the /initial display mode/.+-- 'overlayPossible' can be used to determine if an overlay is possible for the+-- /current window/ with the current /initial display mode/. Do not attempt to+-- establish an overlay when one is not possible; GLUT will terminate the+-- program.+--+-- When 'hasOverlay' is set to 'True' when an overlay already exists, the+-- existing overlay is first removed, and then a new overlay is established. The+-- state of the old overlay\'s OpenGL context is discarded. Implicitly, the+-- window\'s /layer in use/ changes to the overlay immediately after the overlay+-- is established.+--+-- The initial display state of an overlay is shown, however the overlay is only+-- actually shown if the overlay\'s window is shown.+--+-- Setting 'hasOverlay' to 'False' is safe even if no overlay is currently+-- established, nothing happens in this case. Implicitly, the window\'s /layer+-- in use/ changes to the normal plane immediately once the overlay is removed.+--+-- If the program intends to re-establish the overlay later, it is typically+-- faster and less resource intensive to use 'overlayVisible' to simply change+-- the display status of the overlay.+--+-- /X Implementation Notes:/ GLUT for X uses the @SERVER_OVERLAY_VISUALS@+-- convention to determine if overlay visuals are available. While the+-- convention allows for opaque overlays (no transparency) and overlays with the+-- transparency specified as a bitmask, GLUT overlay management only provides+-- access to transparent pixel overlays.+--+-- Until RGBA overlays are better understood, GLUT only supports color index+-- overlays.++hasOverlay :: StateVar Bool+hasOverlay = makeStateVar getHasOverlay setHasOverlay++setHasOverlay :: Bool -> IO ()+setHasOverlay False = glutRemoveOverlay+setHasOverlay True  = glutEstablishOverlay++getHasOverlay :: IO Bool+getHasOverlay = layerGet (/= 0) glut_HAS_OVERLAY++--------------------------------------------------------------------------------++-- | Contains 'True' if an overlay could be established for the /current window/+-- given the current /initial display mode/. If it contains 'False', setting+-- 'hasOverlay' will fail with a fatal error.++overlayPossible :: GettableStateVar Bool+overlayPossible = makeGettableStateVar $ layerGet (/= 0) glut_OVERLAY_POSSIBLE++--------------------------------------------------------------------------------++-- | Controls the visibility of the overlay of the /current window/.+--+-- The effect of showing or hiding an overlay takes place immediately. Note that+-- setting 'overlayVisible' to 'True' will not actually display the overlay+-- unless the window is also shown (and even a shown window may be obscured by+-- other windows, thereby obscuring the overlay). It is typically faster and+-- less resource intensive to use the routines below to control the display+-- status of an overlay as opposed to removing and re-establishing the overlay.++overlayVisible :: SettableStateVar Bool+overlayVisible =+   makeSettableStateVar $ \flag ->+      if flag then glutShowOverlay else glutHideOverlay++--------------------------------------------------------------------------------++-- | The /layer in use/.+data Layer+   = Normal   -- ^ The normal plane.+   | Overlay  -- ^ The overlay.+   deriving ( Eq, Ord, Show )++marshalLayer :: Layer -> GLenum+marshalLayer x = case x of+   Normal -> glut_NORMAL+   Overlay -> glut_OVERLAY++unmarshalLayer :: GLenum -> Layer+unmarshalLayer x+   | x == glut_NORMAL  = Normal+   | x == glut_OVERLAY = Overlay+   | otherwise = error ("unmarshalLayer: illegal value " ++ show x)++--------------------------------------------------------------------------------++-- | Controls the per-window /layer in use/ for the /current window/, which can+-- either be the normal plane or the overlay. Selecting the overlay should only+-- be done if an overlay exists, however windows without an overlay may still+-- set the /layer in use/ to 'Normal'. OpenGL commands for the window are+-- directed to the current /layer in use/.++layerInUse :: StateVar Layer+layerInUse =+   makeStateVar getLayerInUse setLayerInUse++setLayerInUse :: Layer -> IO ()+setLayerInUse = glutUseLayer . marshalLayer++getLayerInUse :: IO Layer+getLayerInUse = layerGet (unmarshalLayer . fromIntegral) glut_LAYER_IN_USE++--------------------------------------------------------------------------------++-- | Mark the overlay of the given window (or the /current window/, if none is+-- supplied) as needing to be redisplayed. The next iteration through+-- 'Graphics.UI.GLUT.Begin.mainLoop', the window\'s overlay display callback+-- (or simply the display callback if no overlay display callback is registered)+-- will be called to redisplay the window\'s overlay plane. Multiple calls to+-- 'postOverlayRedisplay' before the next display callback opportunity (or+-- overlay display callback opportunity if one is registered) generate only a+-- single redisplay. 'postOverlayRedisplay' may be called within a window\'s+-- display or overlay display callback to re-mark that window for redisplay.+--+-- Logically, overlay damage notification for a window is treated as a+-- 'postOverlayRedisplay' on the damaged window. Unlike damage reported by the+-- window system, 'postOverlayRedisplay' will not set to true the overlay\'s+-- damaged status (see 'Graphics.UI.GLUT.State.damaged').+--+-- Also, see 'Graphics.UI.GLUT.Window.postRedisplay'.++postOverlayRedisplay :: Maybe Window -> IO ()+postOverlayRedisplay =+   maybe glutPostOverlayRedisplay (\(Window win) -> glutPostWindowOverlayRedisplay win)
+ src/Graphics/UI/GLUT/QueryUtils.hs view
@@ -0,0 +1,35 @@+{-# OPTIONS_HADDOCK hide #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.QueryUtils+-- Copyright   :  (c) Sven Panne 2002-2013+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- Stability   :  stable+-- Portability :  portable+--+-- This is a purely internal module with utilities to query GLUT state.+--+--------------------------------------------------------------------------------++module Graphics.UI.GLUT.QueryUtils (+  Getter, simpleGet, layerGet, deviceGet+) where++import Foreign.C.Types+import Graphics.Rendering.OpenGL ( GLenum )+import Graphics.UI.GLUT.Raw++--------------------------------------------------------------------------------++type PrimGetter =                GLenum -> IO CInt+type Getter a   = (CInt -> a) -> GLenum -> IO a++makeGetter :: PrimGetter -> Getter a+makeGetter g f = fmap f . g++simpleGet, layerGet, deviceGet :: Getter a+simpleGet = makeGetter glutGet+layerGet  = makeGetter glutLayerGet+deviceGet = makeGetter glutDeviceGet
+ src/Graphics/UI/GLUT/Raw.hs view
@@ -0,0 +1,28 @@+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Raw+-- Copyright   :  (c) Sven Panne 2013+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- Stability   :  stable+-- Portability :  portable+--+-- A convenience module, combining all raw GLUT modules.+--+-----------------------------------------------------------------------------++module Graphics.UI.GLUT.Raw (+   module Graphics.UI.GLUT.Raw.APIEntry,+   module Graphics.UI.GLUT.Raw.Callbacks,+   module Graphics.UI.GLUT.Raw.Fonts,+   module Graphics.UI.GLUT.Raw.Functions,+   module Graphics.UI.GLUT.Raw.Tokens+) where++import Graphics.UI.GLUT.Raw.APIEntry+import Graphics.UI.GLUT.Raw.Callbacks+import Graphics.UI.GLUT.Raw.Fonts+import Graphics.UI.GLUT.Raw.Functions+import Graphics.UI.GLUT.Raw.Tokens
+ src/Graphics/UI/GLUT/Raw/APIEntry.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_HADDOCK hide #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Raw.APIEntry+-- Copyright   :  (c) Sven Panne 2002-2013+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- Stability   :  stable+-- Portability :  portable+--+-- This is a purely internal module for handling an OpenGL-like extension+-- mechanism for GLUT.+--+--------------------------------------------------------------------------------++module Graphics.UI.GLUT.Raw.APIEntry (+   Invoker, getAPIEntry, getAPIEntryInternal,+   FunPtr, unsafePerformIO+) where++import Foreign.C.String+import Foreign.Marshal.Error+import Foreign.Ptr+import System.IO.Unsafe++#ifdef __HUGS__+{-# CFILES cbits/HsGLUT.c #-}+#endif++--------------------------------------------------------------------------------++type Invoker a = FunPtr a -> a++-- | Retrieve a GLUT API entry by name. Throws a userError when no entry with+-- the given name was found.+getAPIEntry :: String -> IO (FunPtr a)+getAPIEntry extensionEntry =+   throwIfNullFunPtr ("unknown GLUT entry " ++ extensionEntry) $+      getAPIEntryInternal extensionEntry++throwIfNullFunPtr :: String -> IO (FunPtr a) -> IO (FunPtr a)+throwIfNullFunPtr = throwIf (== nullFunPtr) . const++getAPIEntryInternal :: String -> IO (FunPtr a)+getAPIEntryInternal extensionEntry =+   withCString extensionEntry hs_GLUT_getProcAddress++foreign import ccall unsafe "hs_GLUT_getProcAddress"+   hs_GLUT_getProcAddress :: CString -> IO (FunPtr a)
+ src/Graphics/UI/GLUT/Raw/Callbacks.hs view
@@ -0,0 +1,242 @@+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Raw.Callbacks+-- Copyright   :  (c) Sven Panne 2013+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- Stability   :  stable+-- Portability :  portable+--+-- All GLUT callbacks.+--+-----------------------------------------------------------------------------++module Graphics.UI.GLUT.Raw.Callbacks (+   AppStatusFunc, makeAppStatusFunc,+   ButtonBoxFunc, makeButtonBoxFunc,+   CloseFunc, makeCloseFunc,+   DialsFunc, makeDialsFunc,+   DisplayFunc, makeDisplayFunc,+   EntryFunc, makeEntryFunc,+   IdleFunc, makeIdleFunc,+   InitContextFunc, makeInitContextFunc,+   JoystickFunc, makeJoystickFunc,+   KeyboardFunc, makeKeyboardFunc,+   KeyboardUpFunc, makeKeyboardUpFunc,+   MenuDestroyFunc, makeMenuDestroyFunc,+   MenuFunc, makeMenuFunc,+   MenuStateFunc, makeMenuStateFunc,+   MenuStatusFunc, makeMenuStatusFunc,+   MotionFunc, makeMotionFunc,+   MouseFunc, makeMouseFunc,+   MouseWheelFunc, makeMouseWheelFunc,+   MultiButtonFunc, makeMultiButtonFunc,+   MultiEntryFunc, makeMultiEntryFunc,+   MultiMotionFunc, makeMultiMotionFunc,+   MultiPassiveFunc, makeMultiPassiveFunc,+   OverlayDisplayFunc, makeOverlayDisplayFunc,+   PassiveMotionFunc, makePassiveMotionFunc,+   PositionFunc, makePositionFunc,+   ReshapeFunc, makeReshapeFunc,+   SpaceballButtonFunc, makeSpaceballButtonFunc,+   SpaceballMotionFunc, makeSpaceballMotionFunc,+   SpaceballRotateFunc, makeSpaceballRotateFunc,+   SpecialFunc, makeSpecialFunc,+   SpecialUpFunc, makeSpecialUpFunc,+   TabletButtonFunc, makeTabletButtonFunc,+   TabletMotionFunc, makeTabletMotionFunc,+   TimerFunc, makeTimerFunc,+   VisibilityFunc, makeVisibilityFunc,+   WMCloseFunc, makeWMCloseFunc,+   WindowStatusFunc, makeWindowStatusFunc+) where++import Foreign.C.Types+import Foreign.Ptr++type AppStatusFunc = CInt -> IO ()++foreign import ccall "wrapper"+   makeAppStatusFunc :: AppStatusFunc -> IO (FunPtr AppStatusFunc)++type ButtonBoxFunc = CInt -> CInt -> IO ()++foreign import ccall "wrapper"+   makeButtonBoxFunc :: ButtonBoxFunc -> IO (FunPtr ButtonBoxFunc)++type CloseFunc = IO ()++foreign import ccall "wrapper"+   makeCloseFunc :: CloseFunc -> IO (FunPtr CloseFunc)++type DialsFunc = CInt -> CInt -> IO ()++foreign import ccall "wrapper"+   makeDialsFunc :: DialsFunc -> IO (FunPtr DialsFunc)++type DisplayFunc = IO ()++foreign import ccall "wrapper"+   makeDisplayFunc :: DisplayFunc -> IO (FunPtr DisplayFunc)++type EntryFunc = CInt -> IO ()++foreign import ccall "wrapper"+   makeEntryFunc :: EntryFunc -> IO (FunPtr EntryFunc)++type IdleFunc = IO ()++foreign import ccall "wrapper"+   makeIdleFunc :: IdleFunc -> IO (FunPtr IdleFunc)++type InitContextFunc = IO ()++foreign import ccall "wrapper"+   makeInitContextFunc :: InitContextFunc -> IO (FunPtr InitContextFunc)++type JoystickFunc = CUInt -> CInt -> CInt -> CInt -> IO ()++foreign import ccall "wrapper"+   makeJoystickFunc :: JoystickFunc -> IO (FunPtr JoystickFunc)++type KeyboardFunc = CUChar -> CInt -> CInt -> IO ()++foreign import ccall "wrapper"+   makeKeyboardFunc :: KeyboardFunc -> IO (FunPtr KeyboardFunc)++type KeyboardUpFunc = CUChar -> CInt -> CInt -> IO ()++foreign import ccall "wrapper"+   makeKeyboardUpFunc :: KeyboardUpFunc -> IO (FunPtr KeyboardUpFunc)++type MenuDestroyFunc = IO ()++foreign import ccall "wrapper"+   makeMenuDestroyFunc :: MenuDestroyFunc -> IO (FunPtr MenuDestroyFunc)++type MenuFunc = CInt -> IO ()++foreign import ccall "wrapper"+   makeMenuFunc :: MenuFunc -> IO (FunPtr MenuFunc)++type MenuStateFunc = CInt -> IO ()++foreign import ccall "wrapper"+   makeMenuStateFunc :: MenuStateFunc -> IO (FunPtr MenuStateFunc)++type MenuStatusFunc = CInt -> CInt -> CInt -> IO ()++foreign import ccall "wrapper"+   makeMenuStatusFunc :: MenuStatusFunc -> IO (FunPtr MenuStatusFunc)++type MotionFunc = CInt -> CInt -> IO ()++foreign import ccall "wrapper"+   makeMotionFunc :: MotionFunc -> IO (FunPtr MotionFunc)++type MouseFunc = CInt -> CInt -> CInt -> CInt -> IO ()++foreign import ccall "wrapper"+   makeMouseFunc :: MouseFunc -> IO (FunPtr MouseFunc)++type MouseWheelFunc = CInt -> CInt -> CInt -> CInt -> IO ()++foreign import ccall "wrapper"+   makeMouseWheelFunc :: MouseWheelFunc -> IO (FunPtr MouseWheelFunc)++type MultiButtonFunc = CInt -> CInt -> CInt -> CInt -> CInt -> IO ()++foreign import ccall "wrapper"+   makeMultiButtonFunc :: MultiButtonFunc -> IO (FunPtr MultiButtonFunc)++type MultiEntryFunc = CInt -> CInt -> IO ()++foreign import ccall "wrapper"+   makeMultiEntryFunc :: MultiEntryFunc -> IO (FunPtr MultiEntryFunc)++type MultiMotionFunc = CInt -> CInt -> CInt -> IO ()++foreign import ccall "wrapper"+   makeMultiMotionFunc :: MultiMotionFunc -> IO (FunPtr MultiMotionFunc)++type MultiPassiveFunc = CInt -> CInt -> CInt -> IO ()++foreign import ccall "wrapper"+   makeMultiPassiveFunc :: MultiPassiveFunc -> IO (FunPtr MultiPassiveFunc)++type OverlayDisplayFunc = IO ()++foreign import ccall "wrapper"+   makeOverlayDisplayFunc :: OverlayDisplayFunc -> IO (FunPtr OverlayDisplayFunc)++type PassiveMotionFunc = CInt -> CInt -> IO ()++foreign import ccall "wrapper"+   makePassiveMotionFunc :: PassiveMotionFunc -> IO (FunPtr PassiveMotionFunc)++type PositionFunc = CInt -> CInt -> IO ()++foreign import ccall "wrapper"+   makePositionFunc :: PositionFunc -> IO (FunPtr PositionFunc)++type ReshapeFunc = CInt -> CInt -> IO ()++foreign import ccall "wrapper"+   makeReshapeFunc :: ReshapeFunc -> IO (FunPtr ReshapeFunc)++type SpaceballButtonFunc = CInt -> CInt -> IO ()++foreign import ccall "wrapper"+   makeSpaceballButtonFunc :: SpaceballButtonFunc -> IO (FunPtr SpaceballButtonFunc)++type SpaceballMotionFunc = CInt -> CInt -> CInt -> IO ()++foreign import ccall "wrapper"+   makeSpaceballMotionFunc :: SpaceballMotionFunc -> IO (FunPtr SpaceballMotionFunc)++type SpaceballRotateFunc = CInt -> CInt -> CInt -> IO ()++foreign import ccall "wrapper"+   makeSpaceballRotateFunc :: SpaceballRotateFunc -> IO (FunPtr SpaceballRotateFunc)++type SpecialFunc = CInt -> CInt -> CInt -> IO ()++foreign import ccall "wrapper"+   makeSpecialFunc :: SpecialFunc -> IO (FunPtr SpecialFunc)++type SpecialUpFunc = CInt -> CInt -> CInt -> IO ()++foreign import ccall "wrapper"+   makeSpecialUpFunc :: SpecialUpFunc -> IO (FunPtr SpecialUpFunc)++type TabletButtonFunc = CInt -> CInt -> CInt -> CInt -> IO ()++foreign import ccall "wrapper"+   makeTabletButtonFunc :: TabletButtonFunc -> IO (FunPtr TabletButtonFunc)++type TabletMotionFunc = CInt -> CInt -> IO ()++foreign import ccall "wrapper"+   makeTabletMotionFunc :: TabletMotionFunc -> IO (FunPtr TabletMotionFunc)++type TimerFunc = CInt -> IO ()++foreign import ccall "wrapper"+   makeTimerFunc :: TimerFunc -> IO (FunPtr TimerFunc)++type VisibilityFunc = CInt -> IO ()++foreign import ccall "wrapper"+   makeVisibilityFunc :: VisibilityFunc -> IO (FunPtr VisibilityFunc)++type WMCloseFunc = IO ()++foreign import ccall "wrapper"+   makeWMCloseFunc :: WMCloseFunc -> IO (FunPtr WMCloseFunc)++type WindowStatusFunc = CInt -> IO ()++foreign import ccall "wrapper"+   makeWindowStatusFunc :: WindowStatusFunc -> IO (FunPtr WindowStatusFunc)
+ src/Graphics/UI/GLUT/Raw/Fonts.hs view
@@ -0,0 +1,92 @@+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Raw.Fonts+-- Copyright   :  (c) Sven Panne 2013+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- Stability   :  stable+-- Portability :  portable+--+-- Our own functions to access font identifiers in a portable way.+--+-----------------------------------------------------------------------------++module Graphics.UI.GLUT.Raw.Fonts (+   BitmapFont(..), GLUTbitmapFont, marshalBitmapFont,+   StrokeFont(..), GLUTstrokeFont, marshalStrokeFont+) where++import Foreign.C.Types+import Foreign.Ptr++--------------------------------------------------------------------------------++-- | The bitmap fonts available in GLUT. The exact bitmap to be used is+-- defined by the standard X glyph bitmaps for the X font with the given name.++data BitmapFont+   = Fixed8By13   -- ^ A fixed width font with every character fitting in an 8+                  --   by 13 pixel rectangle.+                  --   (@-misc-fixed-medium-r-normal--13-120-75-75-C-80-iso8859-1@)+   | Fixed9By15   -- ^ A fixed width font with every character fitting in an 9+                  --   by 15 pixel rectangle.+                  --   (@-misc-fixed-medium-r-normal--15-140-75-75-C-90-iso8859-1@)+   | TimesRoman10 -- ^ A 10-point proportional spaced Times Roman font.+                  --   (@-adobe-times-medium-r-normal--10-100-75-75-p-54-iso8859-1@)+   | TimesRoman24 -- ^ A 24-point proportional spaced Times Roman font.+                  --   (@-adobe-times-medium-r-normal--24-240-75-75-p-124-iso8859-1@)+   | Helvetica10  -- ^ A 10-point proportional spaced Helvetica font.+                  --   (@-adobe-helvetica-medium-r-normal--10-100-75-75-p-56-iso8859-1@)+   | Helvetica12  -- ^ A 12-point proportional spaced Helvetica font.+                  --   (@-adobe-helvetica-medium-r-normal--12-120-75-75-p-67-iso8859-1@)+   | Helvetica18  -- ^ A 18-point proportional spaced Helvetica font.+                  --   (@-adobe-helvetica-medium-r-normal--18-180-75-75-p-98-iso8859-1@)+   deriving ( Eq, Ord, Show )++-- Alas, fonts in GLUT are not denoted by some integral value, but by opaque+-- pointers on the C side. Even worse: For WinDoze, they are simply small ints,+-- casted to void*, for other platforms addresses of global variables are used.+-- And all is done via ugly #ifdef-ed #defines... Aaaaargl! So the only portable+-- way is using integers on the Haskell side and doing the marshaling via some+-- small C wrappers around those macros. *sigh*+type GLUTbitmapFont = Ptr ()++marshalBitmapFont :: BitmapFont -> IO GLUTbitmapFont+marshalBitmapFont x = case x of+   Fixed8By13 -> hs_GLUT_marshalBitmapFont 0+   Fixed9By15 -> hs_GLUT_marshalBitmapFont 1+   TimesRoman10 -> hs_GLUT_marshalBitmapFont 2+   TimesRoman24 -> hs_GLUT_marshalBitmapFont 3+   Helvetica10 -> hs_GLUT_marshalBitmapFont 4+   Helvetica12 -> hs_GLUT_marshalBitmapFont 5+   Helvetica18 -> hs_GLUT_marshalBitmapFont 6+++foreign import ccall unsafe "hs_GLUT_marshalBitmapFont"+   hs_GLUT_marshalBitmapFont :: CInt -> IO (Ptr a)++--------------------------------------------------------------------------------++-- | The stroke fonts available in GLUT.+data StrokeFont+   = Roman     -- ^ A proportionally spaced Roman Simplex font for ASCII+               --   characters 32 through 127. The maximum top character in the+               --   font is 119.05 units; the bottom descends 33.33 units.+   | MonoRoman -- ^ A mono-spaced spaced Roman Simplex font (same characters as+               --   'Roman') for ASCII characters 32 through 127. The maximum+               --   top character in the font is 119.05 units; the bottom+               --   descends 33.33 units. Each character is 104.76 units wide.+   deriving ( Eq, Ord, Show )++-- Same remarks as for GLUTbitmapFont+type GLUTstrokeFont = Ptr ()++marshalStrokeFont :: StrokeFont -> IO GLUTstrokeFont+marshalStrokeFont x = case x of+   Roman -> hs_GLUT_marshalStrokeFont 0+   MonoRoman -> hs_GLUT_marshalStrokeFont 1++foreign import ccall unsafe "hs_GLUT_marshalStrokeFont"+   hs_GLUT_marshalStrokeFont :: CInt -> IO (Ptr a)
+ src/Graphics/UI/GLUT/Raw/Functions.hs view
@@ -0,0 +1,343 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Raw.Functions+-- Copyright   :  (c) Sven Panne 2013+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- Stability   :  stable+-- Portability :  portable+--+-- All raw functions from GLUT and freeglut.+--+-----------------------------------------------------------------------------++module Graphics.UI.GLUT.Raw.Functions (+   glutAddMenuEntry,+   glutAddSubMenu,+   glutAppStatusFunc,+   glutAttachMenu,+   glutBitmapCharacter,+   glutBitmapHeight,+   glutBitmapLength,+   glutBitmapString,+   glutBitmapWidth,+   glutButtonBoxFunc,+   glutChangeToMenuEntry,+   glutChangeToSubMenu,+   glutCloseFunc,+   glutCopyColormap,+   glutCreateMenu,+   glutCreateSubWindow,+   glutCreateWindow,+   glutDestroyMenu,+   glutDestroyWindow,+   glutDetachMenu,+   glutDeviceGet,+   glutDialsFunc,+   glutDisplayFunc,+   glutEnterGameMode,+   glutEntryFunc,+   glutEstablishOverlay,+   glutExit,+   glutExtensionSupported,+   glutForceJoystickFunc,+   glutFullScreen,+   glutFullScreenToggle,+   glutGameModeGet,+   glutGameModeString,+   glutGet,+   glutGetColor,+   glutGetMenu,+   glutGetMenuData,+   glutGetModeValues,+   glutGetModifiers,+   glutGetProcAddress,+   glutGetWindow,+   glutGetWindowData,+   glutHideOverlay,+   glutHideWindow,+   glutIconifyWindow,+   glutIdleFunc,+   glutIgnoreKeyRepeat,+   glutInit,+   glutInitContextFlags,+   glutInitContextFunc,+   glutInitContextProfile,+   glutInitContextVersion,+   glutInitDisplayMode,+   glutInitDisplayString,+   glutInitWindowPosition,+   glutInitWindowSize,+   glutJoystickFunc,+   glutKeyboardFunc,+   glutKeyboardUpFunc,+   glutLayerGet,+   glutLeaveFullScreen,+   glutLeaveGameMode,+   glutLeaveMainLoop,+   glutMainLoop,+   glutMainLoopEvent,+   glutMenuDestroyFunc,+   glutMenuStateFunc,+   glutMenuStatusFunc,+   glutMotionFunc,+   glutMouseFunc,+   glutMouseWheelFunc,+   glutMultiButtonFunc,+   glutMultiEntryFunc,+   glutMultiMotionFunc,+   glutMultiPassiveFunc,+   glutOverlayDisplayFunc,+   glutPassiveMotionFunc,+   glutPopWindow,+   glutPositionFunc,+   glutPositionWindow,+   glutPostOverlayRedisplay,+   glutPostRedisplay,+   glutPostWindowOverlayRedisplay,+   glutPostWindowRedisplay,+   glutPushWindow,+   glutRemoveMenuItem,+   glutRemoveOverlay,+   glutReportErrors,+   glutReshapeFunc,+   glutReshapeWindow,+   glutSetColor,+   glutSetCursor,+   glutSetIconTitle,+   glutSetKeyRepeat,+   glutSetMenu,+   glutSetMenuData,+   glutSetMenuFont,+   glutSetOption,+   glutSetVertexAttribCoord3,+   glutSetVertexAttribNormal,+   glutSetVertexAttribTexCoord2,+   glutSetWindow,+   glutSetWindowData,+   glutSetWindowTitle,+   glutSetupVideoResizing,+   glutShowOverlay,+   glutShowWindow,+   glutSolidCone,+   glutSolidCube,+   glutSolidCylinder,+   glutSolidDodecahedron,+   glutSolidIcosahedron,+   glutSolidOctahedron,+   glutSolidRhombicDodecahedron,+   glutSolidSierpinskiSponge,+   glutSolidSphere,+   glutSolidTeacup,+   glutSolidTeapot,+   glutSolidTeaspoon,+   glutSolidTetrahedron,+   glutSolidTorus,+   glutSpaceballButtonFunc,+   glutSpaceballMotionFunc,+   glutSpaceballRotateFunc,+   glutSpecialFunc,+   glutSpecialUpFunc,+   glutStopVideoResizing,+   glutStrokeCharacter,+   glutStrokeHeight,+   glutStrokeLength,+   glutStrokeString,+   glutStrokeWidth,+   glutSwapBuffers,+   glutTabletButtonFunc,+   glutTabletMotionFunc,+   glutTimerFunc,+   glutUseLayer,+   glutVideoPan,+   glutVideoResize,+   glutVideoResizeGet,+   glutVisibilityFunc,+   glutWMCloseFunc,+   glutWarpPointer,+   glutWindowStatusFunc,+   glutWireCone,+   glutWireCube,+   glutWireCylinder,+   glutWireDodecahedron,+   glutWireIcosahedron,+   glutWireOctahedron,+   glutWireRhombicDodecahedron,+   glutWireSierpinskiSponge,+   glutWireSphere,+   glutWireTeacup,+   glutWireTeapot,+   glutWireTeaspoon,+   glutWireTetrahedron,+   glutWireTorus+) where++import Foreign.C.Types+import Foreign.Ptr+import Graphics.Rendering.OpenGL.Raw.Core31.Types+import Graphics.UI.GLUT.Raw.APIEntry+import Graphics.UI.GLUT.Raw.Callbacks++#include "HsGLUTExt.h"++API_ENTRY(dyn_glutAddMenuEntry,ptr_glutAddMenuEntry,"glutAddMenuEntry",glutAddMenuEntry,Ptr CChar -> CInt -> IO ())+API_ENTRY(dyn_glutAddSubMenu,ptr_glutAddSubMenu,"glutAddSubMenu",glutAddSubMenu,Ptr CChar -> CInt -> IO ())+API_ENTRY(dyn_glutAppStatusFunc,ptr_glutAppStatusFunc,"glutAppStatusFunc",glutAppStatusFunc,FunPtr AppStatusFunc -> IO ())+API_ENTRY(dyn_glutAttachMenu,ptr_glutAttachMenu,"glutAttachMenu",glutAttachMenu,CInt -> IO ())+API_ENTRY(dyn_glutBitmapCharacter,ptr_glutBitmapCharacter,"glutBitmapCharacter",glutBitmapCharacter,Ptr a -> CInt -> IO ())+API_ENTRY(dyn_glutBitmapHeight,ptr_glutBitmapHeight,"glutBitmapHeight",glutBitmapHeight,Ptr a -> IO CInt)+API_ENTRY(dyn_glutBitmapLength,ptr_glutBitmapLength,"glutBitmapLength",glutBitmapLength,Ptr a -> Ptr CUChar -> IO CInt)+API_ENTRY(dyn_glutBitmapString,ptr_glutBitmapString,"glutBitmapString",glutBitmapString,Ptr a -> Ptr CUChar -> IO ())+API_ENTRY(dyn_glutBitmapWidth,ptr_glutBitmapWidth,"glutBitmapWidth",glutBitmapWidth,Ptr a -> CInt -> IO CInt)+API_ENTRY(dyn_glutButtonBoxFunc,ptr_glutButtonBoxFunc,"glutButtonBoxFunc",glutButtonBoxFunc,FunPtr ButtonBoxFunc -> IO ())+API_ENTRY(dyn_glutChangeToMenuEntry,ptr_glutChangeToMenuEntry,"glutChangeToMenuEntry",glutChangeToMenuEntry,CInt -> Ptr CChar -> CInt -> IO ())+API_ENTRY(dyn_glutChangeToSubMenu,ptr_glutChangeToSubMenu,"glutChangeToSubMenu",glutChangeToSubMenu,CInt -> Ptr CChar -> CInt -> IO ())+API_ENTRY(dyn_glutCloseFunc,ptr_glutCloseFunc,"glutCloseFunc",glutCloseFunc,FunPtr CloseFunc -> IO ())+API_ENTRY(dyn_glutCopyColormap,ptr_glutCopyColormap,"glutCopyColormap",glutCopyColormap,CInt -> IO ())+API_ENTRY(dyn_glutCreateMenu,ptr_glutCreateMenu,"glutCreateMenu",glutCreateMenu,FunPtr MenuFunc -> IO CInt)+API_ENTRY(dyn_glutCreateSubWindow,ptr_glutCreateSubWindow,"glutCreateSubWindow",glutCreateSubWindow,CInt -> CInt -> CInt -> CInt -> CInt -> IO CInt)+API_ENTRY(dyn_glutCreateWindow,ptr_glutCreateWindow,"glutCreateWindow",glutCreateWindow,Ptr CChar -> IO CInt)+API_ENTRY(dyn_glutDestroyMenu,ptr_glutDestroyMenu,"glutDestroyMenu",glutDestroyMenu,CInt -> IO ())+API_ENTRY(dyn_glutDestroyWindow,ptr_glutDestroyWindow,"glutDestroyWindow",glutDestroyWindow,CInt -> IO ())+API_ENTRY(dyn_glutDetachMenu,ptr_glutDetachMenu,"glutDetachMenu",glutDetachMenu,CInt -> IO ())+API_ENTRY(dyn_glutDeviceGet,ptr_glutDeviceGet,"glutDeviceGet",glutDeviceGet,GLenum -> IO CInt)+API_ENTRY(dyn_glutDialsFunc,ptr_glutDialsFunc,"glutDialsFunc",glutDialsFunc,FunPtr DialsFunc -> IO ())+API_ENTRY(dyn_glutDisplayFunc,ptr_glutDisplayFunc,"glutDisplayFunc",glutDisplayFunc,FunPtr DisplayFunc -> IO ())+API_ENTRY(dyn_glutEnterGameMode,ptr_glutEnterGameMode,"glutEnterGameMode",glutEnterGameMode,IO CInt)+API_ENTRY(dyn_glutEntryFunc,ptr_glutEntryFunc,"glutEntryFunc",glutEntryFunc,FunPtr EntryFunc -> IO ())+API_ENTRY_SAFE(dyn_glutEstablishOverlay,ptr_glutEstablishOverlay,"glutEstablishOverlay",glutEstablishOverlay,IO ())+API_ENTRY(dyn_glutExit,ptr_glutExit,"glutExit",glutExit,IO ())+API_ENTRY(dyn_glutExtensionSupported,ptr_glutExtensionSupported,"glutExtensionSupported",glutExtensionSupported,Ptr CChar -> IO CInt)+API_ENTRY(dyn_glutForceJoystickFunc,ptr_glutForceJoystickFunc,"glutForceJoystickFunc",glutForceJoystickFunc,IO ())+API_ENTRY(dyn_glutFullScreen,ptr_glutFullScreen,"glutFullScreen",glutFullScreen,IO ())+API_ENTRY(dyn_glutFullScreenToggle,ptr_glutFullScreenToggle,"glutFullScreenToggle",glutFullScreenToggle,IO ())+API_ENTRY(dyn_glutGameModeGet,ptr_glutGameModeGet,"glutGameModeGet",glutGameModeGet,GLenum -> IO CInt)+API_ENTRY(dyn_glutGameModeString,ptr_glutGameModeString,"glutGameModeString",glutGameModeString,Ptr CChar -> IO ())+API_ENTRY(dyn_glutGet,ptr_glutGet,"glutGet",glutGet,GLenum -> IO CInt)+API_ENTRY(dyn_glutGetColor,ptr_glutGetColor,"glutGetColor",glutGetColor,CInt -> CInt -> IO GLfloat)+API_ENTRY(dyn_glutGetMenu,ptr_glutGetMenu,"glutGetMenu",glutGetMenu,IO CInt)+API_ENTRY(dyn_glutGetMenuData,ptr_glutGetMenuData,"glutGetMenuData",glutGetMenuData,IO (Ptr a))+API_ENTRY(dyn_glutGetModeValues,ptr_glutGetModeValues,"glutGetModeValues",glutGetModeValues,GLenum -> Ptr CInt -> IO (Ptr CInt))+API_ENTRY(dyn_glutGetModifiers,ptr_glutGetModifiers,"glutGetModifiers",glutGetModifiers,IO CInt)+API_ENTRY(dyn_glutGetProcAddress,ptr_glutGetProcAddress,"glutGetProcAddress",glutGetProcAddress,Ptr CChar -> IO (FunPtr a))+API_ENTRY(dyn_glutGetWindow,ptr_glutGetWindow,"glutGetWindow",glutGetWindow,IO CInt)+API_ENTRY(dyn_glutGetWindowData,ptr_glutGetWindowData,"glutGetWindowData",glutGetWindowData,IO (Ptr a))+API_ENTRY_SAFE(dyn_glutHideOverlay,ptr_glutHideOverlay,"glutHideOverlay",glutHideOverlay,IO ())+API_ENTRY(dyn_glutHideWindow,ptr_glutHideWindow,"glutHideWindow",glutHideWindow,IO ())+API_ENTRY(dyn_glutIconifyWindow,ptr_glutIconifyWindow,"glutIconifyWindow",glutIconifyWindow,IO ())+API_ENTRY(dyn_glutIdleFunc,ptr_glutIdleFunc,"glutIdleFunc",glutIdleFunc,FunPtr IdleFunc -> IO ())+API_ENTRY(dyn_glutIgnoreKeyRepeat,ptr_glutIgnoreKeyRepeat,"glutIgnoreKeyRepeat",glutIgnoreKeyRepeat,CInt -> IO ())+API_ENTRY(dyn_glutInit,ptr_glutInit,"glutInit",glutInit,Ptr CInt -> Ptr (Ptr CChar) -> IO ())+API_ENTRY(dyn_glutInitContextFlags,ptr_glutInitContextFlags,"glutInitContextFlags",glutInitContextFlags,CInt -> IO ())+API_ENTRY(dyn_glutInitContextFunc,ptr_glutInitContextFunc,"glutInitContextFunc",glutInitContextFunc,FunPtr InitContextFunc -> IO ())+API_ENTRY(dyn_glutInitContextProfile,ptr_glutInitContextProfile,"glutInitContextProfile",glutInitContextProfile,CInt -> IO ())+API_ENTRY(dyn_glutInitContextVersion,ptr_glutInitContextVersion,"glutInitContextVersion",glutInitContextVersion,CInt -> CInt -> IO ())+API_ENTRY(dyn_glutInitDisplayMode,ptr_glutInitDisplayMode,"glutInitDisplayMode",glutInitDisplayMode,CUInt -> IO ())+API_ENTRY(dyn_glutInitDisplayString,ptr_glutInitDisplayString,"glutInitDisplayString",glutInitDisplayString,Ptr CChar -> IO ())+API_ENTRY(dyn_glutInitWindowPosition,ptr_glutInitWindowPosition,"glutInitWindowPosition",glutInitWindowPosition,CInt -> CInt -> IO ())+API_ENTRY(dyn_glutInitWindowSize,ptr_glutInitWindowSize,"glutInitWindowSize",glutInitWindowSize,CInt -> CInt -> IO ())+API_ENTRY(dyn_glutJoystickFunc,ptr_glutJoystickFunc,"glutJoystickFunc",glutJoystickFunc,FunPtr JoystickFunc -> CInt -> IO ())+API_ENTRY(dyn_glutKeyboardFunc,ptr_glutKeyboardFunc,"glutKeyboardFunc",glutKeyboardFunc,FunPtr KeyboardFunc -> IO ())+API_ENTRY(dyn_glutKeyboardUpFunc,ptr_glutKeyboardUpFunc,"glutKeyboardUpFunc",glutKeyboardUpFunc,FunPtr KeyboardUpFunc -> IO ())+API_ENTRY(dyn_glutLayerGet,ptr_glutLayerGet,"glutLayerGet",glutLayerGet,GLenum -> IO CInt)+API_ENTRY(dyn_glutLeaveFullScreen,ptr_glutLeaveFullScreen,"glutLeaveFullScreen",glutLeaveFullScreen,IO ())+API_ENTRY(dyn_glutLeaveGameMode,ptr_glutLeaveGameMode,"glutLeaveGameMode",glutLeaveGameMode,IO ())+API_ENTRY_SAFE(dyn_glutLeaveMainLoop,ptr_glutLeaveMainLoop,"glutLeaveMainLoop",glutLeaveMainLoop,IO ())+API_ENTRY_SAFE(dyn_glutMainLoop,ptr_glutMainLoop,"glutMainLoop",glutMainLoop,IO ())+API_ENTRY_SAFE(dyn_glutMainLoopEvent,ptr_glutMainLoopEvent,"glutMainLoopEvent",glutMainLoopEvent,IO ())+API_ENTRY(dyn_glutMenuDestroyFunc,ptr_glutMenuDestroyFunc,"glutMenuDestroyFunc",glutMenuDestroyFunc,FunPtr MenuDestroyFunc -> IO ())+API_ENTRY(dyn_glutMenuStateFunc,ptr_glutMenuStateFunc,"glutMenuStateFunc",glutMenuStateFunc,FunPtr MenuStateFunc -> IO ())+API_ENTRY(dyn_glutMenuStatusFunc,ptr_glutMenuStatusFunc,"glutMenuStatusFunc",glutMenuStatusFunc,FunPtr MenuStatusFunc -> IO ())+API_ENTRY(dyn_glutMotionFunc,ptr_glutMotionFunc,"glutMotionFunc",glutMotionFunc,FunPtr MotionFunc -> IO ())+API_ENTRY(dyn_glutMouseFunc,ptr_glutMouseFunc,"glutMouseFunc",glutMouseFunc,FunPtr MouseFunc -> IO ())+API_ENTRY(dyn_glutMouseWheelFunc,ptr_glutMouseWheelFunc,"glutMouseWheelFunc",glutMouseWheelFunc,FunPtr MouseWheelFunc -> IO ())+API_ENTRY(dyn_glutMultiButtonFunc,ptr_glutMultiButtonFunc,"glutMultiButtonFunc",glutMultiButtonFunc,FunPtr MultiButtonFunc -> IO ())+API_ENTRY(dyn_glutMultiEntryFunc,ptr_glutMultiEntryFunc,"glutMultiEntryFunc",glutMultiEntryFunc,FunPtr MultiEntryFunc -> IO ())+API_ENTRY(dyn_glutMultiMotionFunc,ptr_glutMultiMotionFunc,"glutMultiMotionFunc",glutMultiMotionFunc,FunPtr MultiMotionFunc -> IO ())+API_ENTRY(dyn_glutMultiPassiveFunc,ptr_glutMultiPassiveFunc,"glutMultiPassiveFunc",glutMultiPassiveFunc,FunPtr MultiPassiveFunc -> IO ())+API_ENTRY(dyn_glutOverlayDisplayFunc,ptr_glutOverlayDisplayFunc,"glutOverlayDisplayFunc",glutOverlayDisplayFunc,FunPtr OverlayDisplayFunc -> IO ())+API_ENTRY(dyn_glutPassiveMotionFunc,ptr_glutPassiveMotionFunc,"glutPassiveMotionFunc",glutPassiveMotionFunc,FunPtr PassiveMotionFunc -> IO ())+API_ENTRY(dyn_glutPopWindow,ptr_glutPopWindow,"glutPopWindow",glutPopWindow,IO ())+API_ENTRY(dyn_glutPositionFunc,ptr_glutPositionFunc,"glutPositionFunc",glutPositionFunc,FunPtr PositionFunc -> IO ())+API_ENTRY(dyn_glutPositionWindow,ptr_glutPositionWindow,"glutPositionWindow",glutPositionWindow,CInt -> CInt -> IO ())+API_ENTRY_SAFE(dyn_glutPostOverlayRedisplay,ptr_glutPostOverlayRedisplay,"glutPostOverlayRedisplay",glutPostOverlayRedisplay,IO ())+API_ENTRY(dyn_glutPostRedisplay,ptr_glutPostRedisplay,"glutPostRedisplay",glutPostRedisplay,IO ())+API_ENTRY_SAFE(dyn_glutPostWindowOverlayRedisplay,ptr_glutPostWindowOverlayRedisplay,"glutPostWindowOverlayRedisplay",glutPostWindowOverlayRedisplay,CInt -> IO ())+API_ENTRY(dyn_glutPostWindowRedisplay,ptr_glutPostWindowRedisplay,"glutPostWindowRedisplay",glutPostWindowRedisplay,CInt -> IO ())+API_ENTRY(dyn_glutPushWindow,ptr_glutPushWindow,"glutPushWindow",glutPushWindow,IO ())+API_ENTRY(dyn_glutRemoveMenuItem,ptr_glutRemoveMenuItem,"glutRemoveMenuItem",glutRemoveMenuItem,CInt -> IO ())+API_ENTRY_SAFE(dyn_glutRemoveOverlay,ptr_glutRemoveOverlay,"glutRemoveOverlay",glutRemoveOverlay,IO ())+API_ENTRY(dyn_glutReportErrors,ptr_glutReportErrors,"glutReportErrors",glutReportErrors,IO ())+API_ENTRY(dyn_glutReshapeFunc,ptr_glutReshapeFunc,"glutReshapeFunc",glutReshapeFunc,FunPtr ReshapeFunc -> IO ())+API_ENTRY(dyn_glutReshapeWindow,ptr_glutReshapeWindow,"glutReshapeWindow",glutReshapeWindow,CInt -> CInt -> IO ())+API_ENTRY(dyn_glutSetColor,ptr_glutSetColor,"glutSetColor",glutSetColor,CInt -> GLfloat -> GLfloat -> GLfloat -> IO ())+API_ENTRY(dyn_glutSetCursor,ptr_glutSetCursor,"glutSetCursor",glutSetCursor,CInt -> IO ())+API_ENTRY(dyn_glutSetIconTitle,ptr_glutSetIconTitle,"glutSetIconTitle",glutSetIconTitle,Ptr CChar -> IO ())+API_ENTRY(dyn_glutSetKeyRepeat,ptr_glutSetKeyRepeat,"glutSetKeyRepeat",glutSetKeyRepeat,CInt -> IO ())+API_ENTRY(dyn_glutSetMenu,ptr_glutSetMenu,"glutSetMenu",glutSetMenu,CInt -> IO ())+API_ENTRY(dyn_glutSetMenuData,ptr_glutSetMenuData,"glutSetMenuData",glutSetMenuData,Ptr a -> IO ())+API_ENTRY(dyn_glutSetMenuFont,ptr_glutSetMenuFont,"glutSetMenuFont",glutSetMenuFont,GLint -> Ptr a -> IO ())+API_ENTRY(dyn_glutSetOption,ptr_glutSetOption,"glutSetOption",glutSetOption,GLenum -> CInt -> IO ())+API_ENTRY(dyn_glutSetVertexAttribCoord3,ptr_glutSetVertexAttribCoord3,"glutSetVertexAttribCoord3",glutSetVertexAttribCoord3,GLint -> IO ())+API_ENTRY(dyn_glutSetVertexAttribNormal,ptr_glutSetVertexAttribNormal,"glutSetVertexAttribNormal",glutSetVertexAttribNormal,GLint -> IO ())+API_ENTRY(dyn_glutSetVertexAttribTexCoord2,ptr_glutSetVertexAttribTexCoord2,"glutSetVertexAttribTexCoord2",glutSetVertexAttribTexCoord2,GLint -> IO ())+API_ENTRY(dyn_glutSetWindow,ptr_glutSetWindow,"glutSetWindow",glutSetWindow,CInt -> IO ())+API_ENTRY(dyn_glutSetWindowData,ptr_glutSetWindowData,"glutSetWindowData",glutSetWindowData,Ptr a -> IO ())+API_ENTRY(dyn_glutSetWindowTitle,ptr_glutSetWindowTitle,"glutSetWindowTitle",glutSetWindowTitle,Ptr CChar -> IO ())+API_ENTRY(dyn_glutSetupVideoResizing,ptr_glutSetupVideoResizing,"glutSetupVideoResizing",glutSetupVideoResizing,IO ())+API_ENTRY_SAFE(dyn_glutShowOverlay,ptr_glutShowOverlay,"glutShowOverlay",glutShowOverlay,IO ())+API_ENTRY(dyn_glutShowWindow,ptr_glutShowWindow,"glutShowWindow",glutShowWindow,IO ())+API_ENTRY(dyn_glutSolidCone,ptr_glutSolidCone,"glutSolidCone",glutSolidCone,GLdouble -> GLdouble -> GLint -> GLint -> IO ())+API_ENTRY(dyn_glutSolidCube,ptr_glutSolidCube,"glutSolidCube",glutSolidCube,GLdouble -> IO ())+API_ENTRY(dyn_glutSolidCylinder,ptr_glutSolidCylinder,"glutSolidCylinder",glutSolidCylinder,GLdouble -> GLdouble -> GLint -> GLint -> IO ())+API_ENTRY(dyn_glutSolidDodecahedron,ptr_glutSolidDodecahedron,"glutSolidDodecahedron",glutSolidDodecahedron,IO ())+API_ENTRY(dyn_glutSolidIcosahedron,ptr_glutSolidIcosahedron,"glutSolidIcosahedron",glutSolidIcosahedron,IO ())+API_ENTRY(dyn_glutSolidOctahedron,ptr_glutSolidOctahedron,"glutSolidOctahedron",glutSolidOctahedron,IO ())+API_ENTRY(dyn_glutSolidRhombicDodecahedron,ptr_glutSolidRhombicDodecahedron,"glutSolidRhombicDodecahedron",glutSolidRhombicDodecahedron,IO ())+API_ENTRY(dyn_glutSolidSierpinskiSponge,ptr_glutSolidSierpinskiSponge,"glutSolidSierpinskiSponge",glutSolidSierpinskiSponge,CInt -> Ptr GLdouble -> GLdouble -> IO ())+API_ENTRY(dyn_glutSolidSphere,ptr_glutSolidSphere,"glutSolidSphere",glutSolidSphere,GLdouble -> GLint -> GLint -> IO ())+API_ENTRY(dyn_glutSolidTeacup,ptr_glutSolidTeacup,"glutSolidTeacup",glutSolidTeacup,GLdouble -> IO ())+API_ENTRY(dyn_glutSolidTeapot,ptr_glutSolidTeapot,"glutSolidTeapot",glutSolidTeapot,GLdouble -> IO ())+API_ENTRY(dyn_glutSolidTeaspoon,ptr_glutSolidTeaspoon,"glutSolidTeaspoon",glutSolidTeaspoon,GLdouble -> IO ())+API_ENTRY(dyn_glutSolidTetrahedron,ptr_glutSolidTetrahedron,"glutSolidTetrahedron",glutSolidTetrahedron,IO ())+API_ENTRY(dyn_glutSolidTorus,ptr_glutSolidTorus,"glutSolidTorus",glutSolidTorus,GLdouble -> GLdouble -> GLint -> GLint -> IO ())+API_ENTRY(dyn_glutSpaceballButtonFunc,ptr_glutSpaceballButtonFunc,"glutSpaceballButtonFunc",glutSpaceballButtonFunc,FunPtr SpaceballButtonFunc -> IO ())+API_ENTRY(dyn_glutSpaceballMotionFunc,ptr_glutSpaceballMotionFunc,"glutSpaceballMotionFunc",glutSpaceballMotionFunc,FunPtr SpaceballMotionFunc -> IO ())+API_ENTRY(dyn_glutSpaceballRotateFunc,ptr_glutSpaceballRotateFunc,"glutSpaceballRotateFunc",glutSpaceballRotateFunc,FunPtr SpaceballRotateFunc -> IO ())+API_ENTRY(dyn_glutSpecialFunc,ptr_glutSpecialFunc,"glutSpecialFunc",glutSpecialFunc,FunPtr SpecialFunc -> IO ())+API_ENTRY(dyn_glutSpecialUpFunc,ptr_glutSpecialUpFunc,"glutSpecialUpFunc",glutSpecialUpFunc,FunPtr SpecialUpFunc -> IO ())+API_ENTRY(dyn_glutStopVideoResizing,ptr_glutStopVideoResizing,"glutStopVideoResizing",glutStopVideoResizing,IO ())+API_ENTRY(dyn_glutStrokeCharacter,ptr_glutStrokeCharacter,"glutStrokeCharacter",glutStrokeCharacter,Ptr a -> CInt -> IO ())+API_ENTRY(dyn_glutStrokeHeight,ptr_glutStrokeHeight,"glutStrokeHeight",glutStrokeHeight,Ptr a -> IO GLfloat)+API_ENTRY(dyn_glutStrokeLength,ptr_glutStrokeLength,"glutStrokeLength",glutStrokeLength,Ptr a -> Ptr CUChar -> IO CInt)+API_ENTRY(dyn_glutStrokeString,ptr_glutStrokeString,"glutStrokeString",glutStrokeString,Ptr a -> Ptr CUChar -> IO ())+API_ENTRY(dyn_glutStrokeWidth,ptr_glutStrokeWidth,"glutStrokeWidth",glutStrokeWidth,Ptr a -> CInt -> IO CInt)+API_ENTRY(dyn_glutSwapBuffers,ptr_glutSwapBuffers,"glutSwapBuffers",glutSwapBuffers,IO ())+API_ENTRY(dyn_glutTabletButtonFunc,ptr_glutTabletButtonFunc,"glutTabletButtonFunc",glutTabletButtonFunc,FunPtr TabletButtonFunc -> IO ())+API_ENTRY(dyn_glutTabletMotionFunc,ptr_glutTabletMotionFunc,"glutTabletMotionFunc",glutTabletMotionFunc,FunPtr TabletMotionFunc -> IO ())+API_ENTRY(dyn_glutTimerFunc,ptr_glutTimerFunc,"glutTimerFunc",glutTimerFunc,CUInt -> FunPtr TimerFunc -> CInt -> IO ())+API_ENTRY_SAFE(dyn_glutUseLayer,ptr_glutUseLayer,"glutUseLayer",glutUseLayer,GLenum -> IO ())+API_ENTRY(dyn_glutVideoPan,ptr_glutVideoPan,"glutVideoPan",glutVideoPan,CInt -> CInt -> CInt -> CInt -> IO ())+API_ENTRY(dyn_glutVideoResize,ptr_glutVideoResize,"glutVideoResize",glutVideoResize,CInt -> CInt -> CInt -> CInt -> IO ())+API_ENTRY(dyn_glutVideoResizeGet,ptr_glutVideoResizeGet,"glutVideoResizeGet",glutVideoResizeGet,GLenum -> IO CInt)+API_ENTRY(dyn_glutVisibilityFunc,ptr_glutVisibilityFunc,"glutVisibilityFunc",glutVisibilityFunc,FunPtr VisibilityFunc -> IO ())+API_ENTRY(dyn_glutWMCloseFunc,ptr_glutWMCloseFunc,"glutWMCloseFunc",glutWMCloseFunc,FunPtr WMCloseFunc -> IO ())+API_ENTRY(dyn_glutWarpPointer,ptr_glutWarpPointer,"glutWarpPointer",glutWarpPointer,CInt -> CInt -> IO ())+API_ENTRY(dyn_glutWindowStatusFunc,ptr_glutWindowStatusFunc,"glutWindowStatusFunc",glutWindowStatusFunc,FunPtr WindowStatusFunc -> IO ())+API_ENTRY(dyn_glutWireCone,ptr_glutWireCone,"glutWireCone",glutWireCone,GLdouble -> GLdouble -> GLint -> GLint -> IO ())+API_ENTRY(dyn_glutWireCube,ptr_glutWireCube,"glutWireCube",glutWireCube,GLdouble -> IO ())+API_ENTRY(dyn_glutWireCylinder,ptr_glutWireCylinder,"glutWireCylinder",glutWireCylinder,GLdouble -> GLdouble -> GLint -> GLint -> IO ())+API_ENTRY(dyn_glutWireDodecahedron,ptr_glutWireDodecahedron,"glutWireDodecahedron",glutWireDodecahedron,IO ())+API_ENTRY(dyn_glutWireIcosahedron,ptr_glutWireIcosahedron,"glutWireIcosahedron",glutWireIcosahedron,IO ())+API_ENTRY(dyn_glutWireOctahedron,ptr_glutWireOctahedron,"glutWireOctahedron",glutWireOctahedron,IO ())+API_ENTRY(dyn_glutWireRhombicDodecahedron,ptr_glutWireRhombicDodecahedron,"glutWireRhombicDodecahedron",glutWireRhombicDodecahedron,IO ())+API_ENTRY(dyn_glutWireSierpinskiSponge,ptr_glutWireSierpinskiSponge,"glutWireSierpinskiSponge",glutWireSierpinskiSponge,CInt -> Ptr GLdouble -> GLdouble -> IO ())+API_ENTRY(dyn_glutWireSphere,ptr_glutWireSphere,"glutWireSphere",glutWireSphere,GLdouble -> GLint -> GLint -> IO ())+API_ENTRY(dyn_glutWireTeacup,ptr_glutWireTeacup,"glutWireTeacup",glutWireTeacup,GLdouble -> IO ())+API_ENTRY(dyn_glutWireTeapot,ptr_glutWireTeapot,"glutWireTeapot",glutWireTeapot,GLdouble -> IO ())+API_ENTRY(dyn_glutWireTeaspoon,ptr_glutWireTeaspoon,"glutWireTeaspoon",glutWireTeaspoon,GLdouble -> IO ())+API_ENTRY(dyn_glutWireTetrahedron,ptr_glutWireTetrahedron,"glutWireTetrahedron",glutWireTetrahedron,IO ())+API_ENTRY(dyn_glutWireTorus,ptr_glutWireTorus,"glutWireTorus",glutWireTorus,GLdouble -> GLdouble -> GLint -> GLint -> IO ())
+ src/Graphics/UI/GLUT/Raw/Tokens.hs view
@@ -0,0 +1,643 @@+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Raw.Tokens+-- Copyright   :  (c) Sven Panne 2013+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- Stability   :  stable+-- Portability :  portable+--+-- All tokens from GLUT and freeglut.+--+-----------------------------------------------------------------------------++module Graphics.UI.GLUT.Raw.Tokens where++import Foreign.C.Types+import Graphics.Rendering.OpenGL ( GLenum )++glut_ACCUM :: CUInt+glut_ACCUM = 0x0004++glut_ACTION_CONTINUE_EXECUTION :: CInt+glut_ACTION_CONTINUE_EXECUTION = 2++glut_ACTION_EXIT :: CInt+glut_ACTION_EXIT = 0++glut_ACTION_GLUTMAINLOOP_RETURNS :: CInt+glut_ACTION_GLUTMAINLOOP_RETURNS = 1++glut_ACTION_ON_WINDOW_CLOSE :: GLenum+glut_ACTION_ON_WINDOW_CLOSE = 0x01F9++glut_ACTIVE_ALT :: CInt+glut_ACTIVE_ALT = 0x0004++glut_ACTIVE_CTRL :: CInt+glut_ACTIVE_CTRL = 0x0002++glut_ACTIVE_SHIFT :: CInt+glut_ACTIVE_SHIFT = 0x0001++glut_ALLOW_DIRECT_CONTEXT :: CInt+glut_ALLOW_DIRECT_CONTEXT = 1++glut_ALPHA :: CUInt+glut_ALPHA = 0x0008++glut_APPSTATUS_PAUSE :: CInt+glut_APPSTATUS_PAUSE = 0x0001++glut_APPSTATUS_RESUME :: CInt+glut_APPSTATUS_RESUME = 0x0002++glut_AUX :: GLenum+glut_AUX = 0x1000++glut_AUX1 :: CUInt+glut_AUX1 = 0x1000++glut_AUX2 :: CUInt+glut_AUX2 = 0x2000++glut_AUX3 :: CUInt+glut_AUX3 = 0x4000++glut_AUX4 :: CUInt+glut_AUX4 = 0x8000++glut_BLUE :: CInt+glut_BLUE = 0x0002++glut_BORDERLESS :: CUInt+glut_BORDERLESS = 0x0800++glut_CAPTIONLESS :: CUInt+glut_CAPTIONLESS = 0x0400++glut_CORE_PROFILE :: CInt+glut_CORE_PROFILE = 0x0001++glut_COMPATIBILITY_PROFILE :: CInt+glut_COMPATIBILITY_PROFILE = 0x0002++glut_CREATE_NEW_CONTEXT :: CInt+glut_CREATE_NEW_CONTEXT = 0++glut_CURSOR_BOTTOM_LEFT_CORNER :: CInt+glut_CURSOR_BOTTOM_LEFT_CORNER = 0x0013++glut_CURSOR_BOTTOM_RIGHT_CORNER :: CInt+glut_CURSOR_BOTTOM_RIGHT_CORNER = 0x0012++glut_CURSOR_BOTTOM_SIDE :: CInt+glut_CURSOR_BOTTOM_SIDE = 0x000D++glut_CURSOR_CROSSHAIR :: CInt+glut_CURSOR_CROSSHAIR = 0x0009++glut_CURSOR_CYCLE :: CInt+glut_CURSOR_CYCLE = 0x0005++glut_CURSOR_DESTROY :: CInt+glut_CURSOR_DESTROY = 0x0003++glut_CURSOR_FULL_CROSSHAIR :: CInt+glut_CURSOR_FULL_CROSSHAIR = 0x0066++glut_CURSOR_HELP :: CInt+glut_CURSOR_HELP = 0x0004++glut_CURSOR_INFO :: CInt+glut_CURSOR_INFO = 0x0002++glut_CURSOR_INHERIT :: CInt+glut_CURSOR_INHERIT = 0x0064++glut_CURSOR_LEFT_ARROW :: CInt+glut_CURSOR_LEFT_ARROW = 0x0001++glut_CURSOR_LEFT_RIGHT :: CInt+glut_CURSOR_LEFT_RIGHT = 0x000B++glut_CURSOR_LEFT_SIDE :: CInt+glut_CURSOR_LEFT_SIDE = 0x000E++glut_CURSOR_NONE :: CInt+glut_CURSOR_NONE = 0x0065++glut_CURSOR_RIGHT_ARROW :: CInt+glut_CURSOR_RIGHT_ARROW = 0x0000++glut_CURSOR_RIGHT_SIDE :: CInt+glut_CURSOR_RIGHT_SIDE = 0x000F++glut_CURSOR_SPRAY :: CInt+glut_CURSOR_SPRAY = 0x0006++glut_CURSOR_TEXT :: CInt+glut_CURSOR_TEXT = 0x0008++glut_CURSOR_TOP_LEFT_CORNER :: CInt+glut_CURSOR_TOP_LEFT_CORNER = 0x0010++glut_CURSOR_TOP_RIGHT_CORNER :: CInt+glut_CURSOR_TOP_RIGHT_CORNER = 0x0011++glut_CURSOR_TOP_SIDE :: CInt+glut_CURSOR_TOP_SIDE = 0x000C++glut_CURSOR_UP_DOWN :: CInt+glut_CURSOR_UP_DOWN = 0x000A++glut_CURSOR_WAIT :: CInt+glut_CURSOR_WAIT = 0x0007++glut_DEBUG :: CInt+glut_DEBUG = 0x0001++glut_DEPTH :: CUInt+glut_DEPTH = 0x0010++glut_DEVICE_IGNORE_KEY_REPEAT :: GLenum+glut_DEVICE_IGNORE_KEY_REPEAT = 0x0262++glut_DEVICE_KEY_REPEAT :: GLenum+glut_DEVICE_KEY_REPEAT = 0x0263++glut_DIRECT_RENDERING :: GLenum+glut_DIRECT_RENDERING = 0x01FE++glut_DISPLAY_MODE_POSSIBLE :: GLenum+glut_DISPLAY_MODE_POSSIBLE = 0x0190++glut_DOUBLE :: CUInt+glut_DOUBLE = 0x0002++glut_DOWN :: CInt+glut_DOWN = 0x0000++glut_ELAPSED_TIME :: GLenum+glut_ELAPSED_TIME = 0x02BC++glut_ENTERED :: CInt+glut_ENTERED = 0x0001++glut_FORCE_DIRECT_CONTEXT :: CInt+glut_FORCE_DIRECT_CONTEXT = 3++glut_FORCE_INDIRECT_CONTEXT :: CInt+glut_FORCE_INDIRECT_CONTEXT = 0++glut_FORWARD_COMPATIBLE :: CInt+glut_FORWARD_COMPATIBLE = 0x0002++glut_FULLY_COVERED :: CInt+glut_FULLY_COVERED = 0x0003++glut_FULLY_RETAINED :: CInt+glut_FULLY_RETAINED = 0x0001++glut_FULL_SCREEN :: GLenum+glut_FULL_SCREEN = 0x01FF++glut_GAME_MODE_ACTIVE :: GLenum+glut_GAME_MODE_ACTIVE = 0x0000++glut_GAME_MODE_DISPLAY_CHANGED :: GLenum+glut_GAME_MODE_DISPLAY_CHANGED = 0x0006++glut_GAME_MODE_HEIGHT :: GLenum+glut_GAME_MODE_HEIGHT = 0x0003++glut_GAME_MODE_PIXEL_DEPTH :: GLenum+glut_GAME_MODE_PIXEL_DEPTH = 0x0004++glut_GAME_MODE_POSSIBLE :: GLenum+glut_GAME_MODE_POSSIBLE = 0x0001++glut_GAME_MODE_REFRESH_RATE :: GLenum+glut_GAME_MODE_REFRESH_RATE = 0x0005++glut_GAME_MODE_WIDTH :: GLenum+glut_GAME_MODE_WIDTH = 0x0002++glut_GEOMETRY_VISUALIZE_NORMALS :: GLenum+glut_GEOMETRY_VISUALIZE_NORMALS = 0x0205++glut_GREEN :: CInt+glut_GREEN = 0x0001++glut_HAS_DIAL_AND_BUTTON_BOX :: GLenum+glut_HAS_DIAL_AND_BUTTON_BOX = 0x025B++glut_HAS_JOYSTICK :: GLenum+glut_HAS_JOYSTICK = 0x0264++glut_HAS_KEYBOARD :: GLenum+glut_HAS_KEYBOARD = 0x0258++glut_HAS_MOUSE :: GLenum+glut_HAS_MOUSE = 0x0259++glut_HAS_OVERLAY :: GLenum+glut_HAS_OVERLAY = 0x0322++glut_HAS_SPACEBALL :: GLenum+glut_HAS_SPACEBALL = 0x025A++glut_HAS_TABLET :: GLenum+glut_HAS_TABLET = 0x025C++glut_HIDDEN :: CInt+glut_HIDDEN = 0x0000++glut_INDEX :: CUInt+glut_INDEX = 0x0001++glut_INIT_DISPLAY_MODE :: GLenum+glut_INIT_DISPLAY_MODE = 0x01F8++glut_INIT_FLAGS :: GLenum+glut_INIT_FLAGS = 0x0202++glut_INIT_MAJOR_VERSION :: GLenum+glut_INIT_MAJOR_VERSION = 0x0200++glut_INIT_MINOR_VERSION :: GLenum+glut_INIT_MINOR_VERSION = 0x0201++glut_INIT_PROFILE :: GLenum+glut_INIT_PROFILE = 0x0203++glut_INIT_STATE :: GLenum+glut_INIT_STATE = 0x007C++glut_INIT_WINDOW_HEIGHT :: GLenum+glut_INIT_WINDOW_HEIGHT = 0x01F7++glut_INIT_WINDOW_WIDTH :: GLenum+glut_INIT_WINDOW_WIDTH = 0x01F6++glut_INIT_WINDOW_X :: GLenum+glut_INIT_WINDOW_X = 0x01F4++glut_INIT_WINDOW_Y :: GLenum+glut_INIT_WINDOW_Y = 0x01F5++glut_JOYSTICK_AXES :: GLenum+glut_JOYSTICK_AXES = 0x0267++glut_JOYSTICK_BUTTONS :: GLenum+glut_JOYSTICK_BUTTONS = 0x0266++glut_JOYSTICK_BUTTON_A :: CUInt+glut_JOYSTICK_BUTTON_A = 0x0001++glut_JOYSTICK_BUTTON_B :: CUInt+glut_JOYSTICK_BUTTON_B = 0x0002++glut_JOYSTICK_BUTTON_C :: CUInt+glut_JOYSTICK_BUTTON_C = 0x0004++glut_JOYSTICK_BUTTON_D :: CUInt+glut_JOYSTICK_BUTTON_D = 0x0008++glut_JOYSTICK_POLL_RATE :: GLenum+glut_JOYSTICK_POLL_RATE = 0x0268++glut_KEY_ALT_L :: CInt+glut_KEY_ALT_L = 0x0074++glut_KEY_ALT_R :: CInt+glut_KEY_ALT_R = 0x0075++glut_KEY_BEGIN :: CInt+glut_KEY_BEGIN = 0x006E++glut_KEY_CTRL_L :: CInt+glut_KEY_CTRL_L = 0x0072++glut_KEY_CTRL_R :: CInt+glut_KEY_CTRL_R = 0x0073++glut_KEY_DELETE :: CInt+glut_KEY_DELETE = 0x006F++glut_KEY_DOWN :: CInt+glut_KEY_DOWN = 0x0067++glut_KEY_END :: CInt+glut_KEY_END = 0x006B++glut_KEY_F1 :: CInt+glut_KEY_F1 = 0x0001++glut_KEY_F10 :: CInt+glut_KEY_F10 = 0x000A++glut_KEY_F11 :: CInt+glut_KEY_F11 = 0x000B++glut_KEY_F12 :: CInt+glut_KEY_F12 = 0x000C++glut_KEY_F2 :: CInt+glut_KEY_F2 = 0x0002++glut_KEY_F3 :: CInt+glut_KEY_F3 = 0x0003++glut_KEY_F4 :: CInt+glut_KEY_F4 = 0x0004++glut_KEY_F5 :: CInt+glut_KEY_F5 = 0x0005++glut_KEY_F6 :: CInt+glut_KEY_F6 = 0x0006++glut_KEY_F7 :: CInt+glut_KEY_F7 = 0x0007++glut_KEY_F8 :: CInt+glut_KEY_F8 = 0x0008++glut_KEY_F9 :: CInt+glut_KEY_F9 = 0x0009++glut_KEY_HOME :: CInt+glut_KEY_HOME = 0x006A++glut_KEY_INSERT :: CInt+glut_KEY_INSERT = 0x006C++glut_KEY_LEFT :: CInt+glut_KEY_LEFT = 0x0064++glut_KEY_NUM_LOCK :: CInt+glut_KEY_NUM_LOCK = 0x006D++glut_KEY_PAGE_DOWN :: CInt+glut_KEY_PAGE_DOWN = 0x0069++glut_KEY_PAGE_UP :: CInt+glut_KEY_PAGE_UP = 0x0068++glut_KEY_REPEAT_DEFAULT :: CInt+glut_KEY_REPEAT_DEFAULT = 0x0002++glut_KEY_REPEAT_OFF :: CInt+glut_KEY_REPEAT_OFF = 0x0000++glut_KEY_REPEAT_ON :: CInt+glut_KEY_REPEAT_ON = 0x0001++glut_KEY_RIGHT :: CInt+glut_KEY_RIGHT = 0x0066++glut_KEY_SHIFT_L :: CInt+glut_KEY_SHIFT_L = 0x0070++glut_KEY_SHIFT_R :: CInt+glut_KEY_SHIFT_R = 0x0071++glut_KEY_UP :: CInt+glut_KEY_UP = 0x0065++glut_LAYER_IN_USE :: GLenum+glut_LAYER_IN_USE = 0x0321++glut_LEFT :: CInt+glut_LEFT = 0x0000++glut_LEFT_BUTTON :: CInt+glut_LEFT_BUTTON = 0x0000++glut_LUMINANCE :: CUInt+glut_LUMINANCE = 0x0200++glut_MENU_IN_USE :: CInt+glut_MENU_IN_USE = 0x0001++glut_MENU_NOT_IN_USE :: CInt+glut_MENU_NOT_IN_USE = 0x0000++glut_MENU_NUM_ITEMS :: GLenum+glut_MENU_NUM_ITEMS = 0x012C++glut_MIDDLE_BUTTON :: CInt+glut_MIDDLE_BUTTON = 0x0001++glut_MULTISAMPLE :: CUInt+glut_MULTISAMPLE = 0x0080++glut_NORMAL :: GLenum+glut_NORMAL = 0x0000++glut_NORMAL_DAMAGED :: GLenum+glut_NORMAL_DAMAGED = 0x0324++glut_NOT_VISIBLE :: CInt+glut_NOT_VISIBLE = 0x0000++glut_NUM_BUTTON_BOX_BUTTONS :: GLenum+glut_NUM_BUTTON_BOX_BUTTONS = 0x025F++glut_NUM_DIALS :: GLenum+glut_NUM_DIALS = 0x0260++glut_NUM_MOUSE_BUTTONS :: GLenum+glut_NUM_MOUSE_BUTTONS = 0x025D++glut_NUM_SPACEBALL_BUTTONS :: GLenum+glut_NUM_SPACEBALL_BUTTONS = 0x025E++glut_NUM_TABLET_BUTTONS :: GLenum+glut_NUM_TABLET_BUTTONS = 0x0261++glut_OVERLAY :: GLenum+glut_OVERLAY = 0x0001++glut_OVERLAY_DAMAGED :: GLenum+glut_OVERLAY_DAMAGED = 0x0325++glut_OVERLAY_POSSIBLE :: GLenum+glut_OVERLAY_POSSIBLE = 0x0320++glut_OWNS_JOYSTICK :: GLenum+glut_OWNS_JOYSTICK = 0x0265++glut_PARTIALLY_RETAINED :: CInt+glut_PARTIALLY_RETAINED = 0x0002++glut_RED :: CInt+glut_RED = 0x0000++glut_RENDERING_CONTEXT :: GLenum+glut_RENDERING_CONTEXT = 0x01FD++glut_RGB :: CUInt+glut_RGB = 0x0000++glut_RGBA :: CUInt+glut_RGBA = 0x0000++glut_RIGHT_BUTTON :: CInt+glut_RIGHT_BUTTON = 0x0002++glut_SCREEN_HEIGHT :: GLenum+glut_SCREEN_HEIGHT = 0x00C9++glut_SCREEN_HEIGHT_MM :: GLenum+glut_SCREEN_HEIGHT_MM = 0x00CB++glut_SCREEN_WIDTH :: GLenum+glut_SCREEN_WIDTH = 0x00C8++glut_SCREEN_WIDTH_MM :: GLenum+glut_SCREEN_WIDTH_MM = 0x00CA++glut_SINGLE :: CUInt+glut_SINGLE = 0x0000++glut_SKIP_STALE_MOTION_EVENTS :: GLenum+glut_SKIP_STALE_MOTION_EVENTS = 0x0204++glut_SRGB :: CUInt+glut_SRGB = 0x1000++glut_STENCIL :: CUInt+glut_STENCIL = 0x0020++glut_STEREO :: CUInt+glut_STEREO = 0x0100++glut_TRANSPARENT_INDEX :: GLenum+glut_TRANSPARENT_INDEX = 0x0323++glut_TRY_DIRECT_CONTEXT :: CInt+glut_TRY_DIRECT_CONTEXT = 2++glut_UP :: CInt+glut_UP = 0x0001++glut_USE_CURRENT_CONTEXT :: CInt+glut_USE_CURRENT_CONTEXT = 1++glut_VERSION :: GLenum+glut_VERSION = 0x01FC++glut_VIDEO_RESIZE_HEIGHT :: GLenum+glut_VIDEO_RESIZE_HEIGHT = 0x038D++glut_VIDEO_RESIZE_HEIGHT_DELTA :: GLenum+glut_VIDEO_RESIZE_HEIGHT_DELTA = 0x0389++glut_VIDEO_RESIZE_IN_USE :: GLenum+glut_VIDEO_RESIZE_IN_USE = 0x0385++glut_VIDEO_RESIZE_POSSIBLE :: GLenum+glut_VIDEO_RESIZE_POSSIBLE = 0x0384++glut_VIDEO_RESIZE_WIDTH :: GLenum+glut_VIDEO_RESIZE_WIDTH = 0x038C++glut_VIDEO_RESIZE_WIDTH_DELTA :: GLenum+glut_VIDEO_RESIZE_WIDTH_DELTA = 0x0388++glut_VIDEO_RESIZE_X :: GLenum+glut_VIDEO_RESIZE_X = 0x038A++glut_VIDEO_RESIZE_X_DELTA :: GLenum+glut_VIDEO_RESIZE_X_DELTA = 0x0386++glut_VIDEO_RESIZE_Y :: GLenum+glut_VIDEO_RESIZE_Y = 0x038B++glut_VIDEO_RESIZE_Y_DELTA :: GLenum+glut_VIDEO_RESIZE_Y_DELTA = 0x0387++glut_VISIBLE :: CInt+glut_VISIBLE = 0x0001++glut_WINDOW_ACCUM_ALPHA_SIZE :: GLenum+glut_WINDOW_ACCUM_ALPHA_SIZE = 0x0072++glut_WINDOW_ACCUM_BLUE_SIZE :: GLenum+glut_WINDOW_ACCUM_BLUE_SIZE = 0x0071++glut_WINDOW_ACCUM_GREEN_SIZE :: GLenum+glut_WINDOW_ACCUM_GREEN_SIZE = 0x0070++glut_WINDOW_ACCUM_RED_SIZE :: GLenum+glut_WINDOW_ACCUM_RED_SIZE = 0x006F++glut_WINDOW_ALPHA_SIZE :: GLenum+glut_WINDOW_ALPHA_SIZE = 0x006E++glut_WINDOW_BLUE_SIZE :: GLenum+glut_WINDOW_BLUE_SIZE = 0x006D++glut_WINDOW_BORDER_WIDTH :: GLenum+glut_WINDOW_BORDER_WIDTH = 0x01FA++glut_WINDOW_BUFFER_SIZE :: GLenum+glut_WINDOW_BUFFER_SIZE = 0x0068++glut_WINDOW_COLORMAP_SIZE :: GLenum+glut_WINDOW_COLORMAP_SIZE = 0x0077++glut_WINDOW_CURSOR :: GLenum+glut_WINDOW_CURSOR = 0x007A++glut_WINDOW_DEPTH_SIZE :: GLenum+glut_WINDOW_DEPTH_SIZE = 0x006A++glut_WINDOW_DOUBLEBUFFER :: GLenum+glut_WINDOW_DOUBLEBUFFER = 0x0073++glut_WINDOW_FORMAT_ID :: GLenum+glut_WINDOW_FORMAT_ID = 0x007B++glut_WINDOW_GREEN_SIZE :: GLenum+glut_WINDOW_GREEN_SIZE = 0x006C++glut_WINDOW_HEADER_HEIGHT :: GLenum+glut_WINDOW_HEADER_HEIGHT = 0x01FB++glut_WINDOW_HEIGHT :: GLenum+glut_WINDOW_HEIGHT = 0x0067++glut_WINDOW_NUM_CHILDREN :: GLenum+glut_WINDOW_NUM_CHILDREN = 0x0076++glut_WINDOW_NUM_SAMPLES :: GLenum+glut_WINDOW_NUM_SAMPLES = 0x0078++glut_WINDOW_PARENT :: GLenum+glut_WINDOW_PARENT = 0x0075++glut_WINDOW_RED_SIZE :: GLenum+glut_WINDOW_RED_SIZE = 0x006B++glut_WINDOW_RGBA :: GLenum+glut_WINDOW_RGBA = 0x0074++glut_WINDOW_STENCIL_SIZE :: GLenum+glut_WINDOW_STENCIL_SIZE = 0x0069++glut_WINDOW_STEREO :: GLenum+glut_WINDOW_STEREO = 0x0079++glut_WINDOW_WIDTH :: GLenum+glut_WINDOW_WIDTH = 0x0066++glut_WINDOW_X :: GLenum+glut_WINDOW_X = 0x0064++glut_WINDOW_Y :: GLenum+glut_WINDOW_Y = 0x0065
+ src/Graphics/UI/GLUT/State.hs view
@@ -0,0 +1,446 @@+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.State+-- Copyright   :  (c) Sven Panne 2002-2013+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- Stability   :  stable+-- Portability :  portable+--+-- GLUT maintains a considerable amount of programmer visible state. Some (but+-- not all) of this state may be directly retrieved.+--+--------------------------------------------------------------------------------++module Graphics.UI.GLUT.State (+   -- * State of all windows+   windowBorderWidth, windowHeaderHeight, skipStaleMotionEvents,++   -- * State of the /current window/++   -- ** Framebuffer state+   rgba,+   BufferDepth, rgbaBufferDepths, colorBufferDepth,+   doubleBuffered, stereo,+   accumBufferDepths, depthBufferDepth, stencilBufferDepth,+   SampleCount, sampleCount, formatID,++   -- ** Full screen state+   fullScreenMode,++   -- ** Object rendering state+   geometryVisualizeNormals,++   -- ** Vertex attribute state+   vertexAttribCoord3, vertexAttribNormal, vertexAttribTexCoord2,++   -- ** Layer state+   damaged,++   -- * Timing+   elapsedTime,++   -- * Device information++   -- $DeviceInformation+   screenSize, screenSizeMM,+   hasKeyboard,+   ButtonCount, numMouseButtons,+   numSpaceballButtons,+   DialCount, numDialsAndButtons,+   numTabletButtons,+   AxisCount, PollRate, joystickInfo,+   supportedNumAuxBuffers, supportedSamplesPerPixel,++   -- * GLUT information+   glutVersion, initState+) where++import Control.Monad+import Foreign.C.Types+import Foreign.Marshal.Alloc+import Foreign.Marshal.Array+import Foreign.Ptr+import Foreign.Storable+import Graphics.Rendering.OpenGL+import Graphics.UI.GLUT.Overlay+import Graphics.UI.GLUT.QueryUtils+import Graphics.UI.GLUT.Raw+import Graphics.UI.GLUT.Window++--------------------------------------------------------------------------------++-- | Contains 'True' when the current layer of the /current window/ is in RGBA+-- mode, 'False' means color index mode.++rgba :: GettableStateVar Bool+rgba = makeGettableStateVar$ simpleGet i2b glut_WINDOW_RGBA++-- | Bit depth of a buffer++type BufferDepth = Int++-- | Contains the number of red, green, blue, and alpha bits in the color buffer+-- of the /current window\'s/ current layer (0 in color index mode).++rgbaBufferDepths ::+   GettableStateVar (BufferDepth, BufferDepth, BufferDepth, BufferDepth)+rgbaBufferDepths = makeGettableStateVar $ do+   r <- simpleGet fromIntegral glut_WINDOW_RED_SIZE+   g <- simpleGet fromIntegral glut_WINDOW_GREEN_SIZE+   b <- simpleGet fromIntegral glut_WINDOW_BLUE_SIZE+   a <- simpleGet fromIntegral glut_WINDOW_ALPHA_SIZE+   return (r, g, b, a)++-- | Contains the total number of bits in the color buffer of the /current+-- window\'s/ current layer. For an RGBA layer, this is the sum of the red,+-- green, blue, and alpha bits. For an color index layer, this is the number+-- of bits of the color indexes.++colorBufferDepth :: GettableStateVar BufferDepth+colorBufferDepth =+   makeGettableStateVar $ simpleGet fromIntegral glut_WINDOW_BUFFER_SIZE++-- | Contains 'True' when the current layer of the /current window/ is double+-- buffered, 'False' otherwise.++doubleBuffered :: GettableStateVar Bool+doubleBuffered = makeGettableStateVar $ simpleGet i2b glut_WINDOW_DOUBLEBUFFER++-- | Contains 'True' when the current layer of the /current window/ is stereo,+-- 'False' otherwise.++stereo :: GettableStateVar Bool+stereo = makeGettableStateVar $ simpleGet i2b glut_WINDOW_STEREO++-- | Contains the number of red, green, blue, and alpha bits in the accumulation+-- buffer of the /current window\'s/ current layer (0 in color index mode).++accumBufferDepths ::+   GettableStateVar (BufferDepth, BufferDepth, BufferDepth, BufferDepth)+accumBufferDepths = makeGettableStateVar $ do+   r <- simpleGet fromIntegral glut_WINDOW_ACCUM_RED_SIZE+   g <- simpleGet fromIntegral glut_WINDOW_ACCUM_GREEN_SIZE+   b <- simpleGet fromIntegral glut_WINDOW_ACCUM_BLUE_SIZE+   a <- simpleGet fromIntegral glut_WINDOW_ACCUM_ALPHA_SIZE+   return (r, g, b, a)++-- | Contains the number of bits in the depth buffer of the /current window\'s/+-- current layer.++depthBufferDepth :: GettableStateVar BufferDepth+depthBufferDepth =+   makeGettableStateVar $ simpleGet fromIntegral glut_WINDOW_DEPTH_SIZE++-- | Contains the number of bits in the stencil buffer of the /current+-- window\'s/ current layer.++stencilBufferDepth :: GettableStateVar BufferDepth+stencilBufferDepth =+   makeGettableStateVar $ simpleGet fromIntegral glut_WINDOW_STENCIL_SIZE++-- | Number of samples for multisampling++type SampleCount = Int++-- | Contains the number of samples for multisampling for the /current window./++sampleCount :: GettableStateVar SampleCount+sampleCount =+   makeGettableStateVar $ simpleGet fromIntegral glut_WINDOW_NUM_SAMPLES++-- | Contains the window system dependent format ID for the current layer of the+-- /current window/. On X11 GLUT implementations, this is the X visual ID. On+-- Win32 GLUT implementations, this is the Win32 Pixel Format Descriptor number.+-- This value is returned for debugging, benchmarking, and testing ease.++formatID :: GettableStateVar Int+formatID = makeGettableStateVar $ simpleGet fromIntegral glut_WINDOW_FORMAT_ID++--------------------------------------------------------------------------------++-- | (/freeglut only/) Contains 'True' if the /current window/ is in full screen+-- mode, 'False' otherwise.++fullScreenMode :: StateVar Bool+fullScreenMode = makeStateVar getFullScreenMode setFullScreenMode++getFullScreenMode :: IO Bool+getFullScreenMode = simpleGet i2b glut_FULL_SCREEN++setFullScreenMode :: Bool -> IO ()+setFullScreenMode newMode = do+   oldMode <- getFullScreenMode+   unless (newMode == oldMode) fullScreenToggle++--------------------------------------------------------------------------------++-- | (/freeglut only/) Controls if vectors representing the normals should be+-- drawn, too, when objects are drawn.++geometryVisualizeNormals :: StateVar Bool+geometryVisualizeNormals =+   makeStateVar+      (simpleGet i2b glut_GEOMETRY_VISUALIZE_NORMALS)+      (glutSetOption glut_GEOMETRY_VISUALIZE_NORMALS . b2i)+++--------------------------------------------------------------------------------++-- | (/freeglut only/) If 'vertexAttribCoord3' and 'vertexAttribNormal' both+-- contain 'Nothing', the fixed function pipeline is used to draw+-- objects. Otherwise VBOs are used and the coordinates are passed via 'Just'+-- this attribute location (for a vec3).++vertexAttribCoord3 :: SettableStateVar (Maybe AttribLocation)+vertexAttribCoord3 = setVertexAttribWith glutSetVertexAttribCoord3++setVertexAttribWith :: (GLint -> IO ()) -> SettableStateVar (Maybe AttribLocation)+setVertexAttribWith f = makeSettableStateVar $ f . getLocation+   where getLocation = maybe (-1) (\(AttribLocation l) -> fromIntegral l)++-- | (/freeglut only/) If 'vertexAttribCoord3' and 'vertexAttribNormal' both+-- contain 'Nothing', the fixed function pipeline is used to draw+-- objects. Otherwise VBOs are used and the normals are passed via 'Just' this+-- attribute location (for a vec3).++vertexAttribNormal :: SettableStateVar (Maybe AttribLocation)+vertexAttribNormal = setVertexAttribWith glutSetVertexAttribNormal++-- | (/freeglut only/) If VBOs are used to draw objects (controlled via+-- 'vertexAttribCoord3' and 'vertexAttribNormal'), the texture coordinates are+-- passed via 'Just' this attribute location (for a vec2).++vertexAttribTexCoord2 :: SettableStateVar (Maybe AttribLocation)+vertexAttribTexCoord2 = setVertexAttribWith glutSetVertexAttribTexCoord2++--------------------------------------------------------------------------------++-- | Contains the number of milliseconds since+-- 'Graphics.UI.GLUT.Initialization.initialize' was called.++elapsedTime :: GettableStateVar Int+elapsedTime = makeGettableStateVar $ simpleGet fromIntegral glut_ELAPSED_TIME++--------------------------------------------------------------------------------++-- | Contains 'True' if the given plane of the /current window/ has been+-- damaged (by window system activity) since the last display callback was+-- triggered. Calling 'Graphics.UI.GLUT.Window.postRedisplay' or+-- 'Graphics.UI.GLUT.Overlay.postOverlayRedisplay' will not set this 'True'.++damaged :: Layer -> GettableStateVar Bool+damaged l = makeGettableStateVar $ layerGet isDamaged (marshalDamagedLayer l)+   where isDamaged d = d /= 0 && d /= -1+         marshalDamagedLayer x = case x of+            Normal -> glut_NORMAL_DAMAGED+            Overlay -> glut_OVERLAY_DAMAGED++--------------------------------------------------------------------------------++-- $DeviceInformation+-- If a device is not available, the following state variables contain+-- 'Nothing', otherwise they return 'Just' the specific device information.+-- Only a screen is always assumed.++--------------------------------------------------------------------------------++-- | The size of the screen in pixels.++screenSize :: GettableStateVar Size+screenSize =+   makeGettableStateVar $ do+      wpx <- simpleGet fromIntegral glut_SCREEN_WIDTH+      hpx <- simpleGet fromIntegral glut_SCREEN_HEIGHT+      return $ Size wpx hpx++-- | The size of the screen in millimeters.++screenSizeMM :: GettableStateVar Size+screenSizeMM =+   makeGettableStateVar $ do+      wmm <- simpleGet fromIntegral glut_SCREEN_WIDTH_MM+      hmm <- simpleGet fromIntegral glut_SCREEN_HEIGHT_MM+      return $ Size wmm hmm++--------------------------------------------------------------------------------++-- | Contains 'True' if a keyboard is present, 'False' otherwise.++hasKeyboard :: GettableStateVar Bool+hasKeyboard = makeGettableStateVar $ deviceGet i2b glut_HAS_KEYBOARD++--------------------------------------------------------------------------------++-- | Number of buttons of an input device++type ButtonCount = Int++-- | Contains 'Just' the number of buttons of an attached mouse or 'Nothing' if+-- there is none.++numMouseButtons :: GettableStateVar (Maybe ButtonCount)+numMouseButtons =+   getDeviceInfo glut_HAS_MOUSE $+      deviceGet fromIntegral glut_NUM_MOUSE_BUTTONS++--------------------------------------------------------------------------------++-- | Contains 'Just' the number of buttons of the attached Spaceball or 'Nothing'+-- if there is none.++numSpaceballButtons :: GettableStateVar (Maybe ButtonCount)+numSpaceballButtons =+   getDeviceInfo glut_HAS_SPACEBALL $+      deviceGet fromIntegral glut_NUM_SPACEBALL_BUTTONS++--------------------------------------------------------------------------------++-- | Number of dials of a dial and button box++type DialCount = Int++-- | Contains 'Just' the number of dials and buttons of an attached dial &+-- button box or 'Nothing' if there is none.++numDialsAndButtons :: GettableStateVar (Maybe (DialCount, ButtonCount))+numDialsAndButtons =+   getDeviceInfo glut_HAS_DIAL_AND_BUTTON_BOX $ do+      d <- deviceGet fromIntegral glut_NUM_DIALS+      b <- deviceGet fromIntegral glut_NUM_BUTTON_BOX_BUTTONS+      return (d, b)++--------------------------------------------------------------------------------++-- | Contains 'Just' the number of buttons of an attached tablet or 'Nothing' if+-- there is none.++numTabletButtons :: GettableStateVar (Maybe ButtonCount)+numTabletButtons =+   getDeviceInfo glut_HAS_TABLET $+      deviceGet fromIntegral glut_NUM_TABLET_BUTTONS++--------------------------------------------------------------------------------++-- | Number of axes of a joystick++type AxisCount = Int++-- | The a rate at which a joystick is polled (in milliseconds)++type PollRate = Int++-- | Contains 'Just' the number of buttons of an attached joystick, the number+-- of joystick axes, and the rate at which the joystick is polled. Contains+-- 'Nothing' if there is no joystick attached.++joystickInfo :: GettableStateVar (Maybe (ButtonCount, PollRate, AxisCount))+joystickInfo =+   getDeviceInfo glut_HAS_JOYSTICK $ do+      b <- deviceGet fromIntegral glut_JOYSTICK_BUTTONS+      a <- deviceGet fromIntegral glut_JOYSTICK_AXES+      r <- deviceGet fromIntegral glut_JOYSTICK_POLL_RATE+      return (b, a, r)++-----------------------------------------------------------------------------++-- | (/freeglut only/) Contains a list of the number of auxiliary buffers+-- supported, in increasing order.++supportedNumAuxBuffers :: GettableStateVar [Int]+supportedNumAuxBuffers = getModeValues glut_AUX++-- | (/freeglut only/) Contains a list of the number of samples per pixel+-- supported for multisampling, in increasing order.++supportedSamplesPerPixel :: GettableStateVar [SampleCount]+supportedSamplesPerPixel = getModeValues (fromIntegral glut_MULTISAMPLE)++getModeValues :: Integral a => GLenum -> GettableStateVar [a]+getModeValues what = makeGettableStateVar $+   alloca $ \sizeBuffer -> do+      valuesBuffer <- glutGetModeValues what sizeBuffer+      size <- peek sizeBuffer+      fmap (map fromIntegral) $ peekArray (fromIntegral size) valuesBuffer++--------------------------------------------------------------------------------+-- Convenience (un-)marshalers++i2b :: CInt -> Bool+i2b = (/= 0)++b2i :: Bool ->  CInt+b2i False = 0+b2i True = 1++--------------------------------------------------------------------------------++getDeviceInfo :: GLenum -> IO a -> GettableStateVar (Maybe a)+getDeviceInfo dev act =+   makeGettableStateVar $ do+      hasDevice <- deviceGet i2b dev+      if hasDevice then fmap Just act else return Nothing++-----------------------------------------------------------------------------++-- | Contains version of GLUT in the form of+-- @/flavour/ /major/./minor/./patchlevel/@, where @/flavour/@ is one of+-- @GLUT@, @freeglut@ or @OpenGLUT@.++glutVersion :: GettableStateVar String+glutVersion = makeGettableStateVar $ do+   let isGLUT = isUnknown "glutSetOption"+       isFreeglut = isUnknown "glutSetWindowStayOnTop"+       isUnknown = fmap (== nullFunPtr) . getAPIEntryInternal+       showVersionPart x = shows (x `mod` 100)+       showVersion v = showVersionPart (v `div` 10000) . showChar '.' .+                       showVersionPart (v `div`   100) . showChar '.' .+                       showVersionPart  v+   g <- isGLUT+   if g+      then return "GLUT 3.7"   -- ToDo: just guessing+      else do f <- isFreeglut+              v <- simpleGet id glut_VERSION+              let prefix = if f then "freeglut" else "OpenGLUT"+              return $ showString prefix . showChar ' ' . showVersion v $ ""++-----------------------------------------------------------------------------++-- | (/freeglut only/) Contains the thickness of the sizing border around the+-- perimeter of a window that can be resized, in pixels.++windowBorderWidth :: GettableStateVar Int+windowBorderWidth =+   makeGettableStateVar (simpleGet fromIntegral glut_WINDOW_BORDER_WIDTH)++-----------------------------------------------------------------------------++-- | (/freeglut only/) Contains the height of the header\/caption area of a+-- window in pixels.++windowHeaderHeight :: GettableStateVar Int+windowHeaderHeight =+   makeGettableStateVar (simpleGet fromIntegral glut_WINDOW_HEADER_HEIGHT)++-----------------------------------------------------------------------------++-- | (/freeglut on X11 only/) Controls if all but the last motion event should+-- be discarded.++skipStaleMotionEvents :: StateVar Bool+skipStaleMotionEvents =+   makeStateVar+      (simpleGet i2b glut_SKIP_STALE_MOTION_EVENTS)+      (glutSetOption glut_SKIP_STALE_MOTION_EVENTS . b2i)++-----------------------------------------------------------------------------++-- | (/freeglut only/) Contains 'True' if GLUT has been initialized +-- with 'Graphics.UI.GLUT.Initialization.initialize' or+-- 'Graphics.UI.GLUT.Initialization.getArgsAndInitialize' has and not yet+-- been de-initialized with 'Graphics.UI.GLUT.Initialization.exit'. Contains+-- 'False' otherwise.++initState :: GettableStateVar Bool+initState = makeGettableStateVar$ simpleGet i2b glut_INIT_STATE
+ src/Graphics/UI/GLUT/Types.hs view
@@ -0,0 +1,104 @@+{-# OPTIONS_HADDOCK hide #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Types+-- Copyright   :  (c) Sven Panne 2002-2013+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- Stability   :  stable+-- Portability :  portable+--+-- This is a purely internal module with miscellaneous types which don\'t really+-- have a good place elsewhere.+--+--------------------------------------------------------------------------------++module Graphics.UI.GLUT.Types (+   Window(..),                               -- constructor used only internally+   Relation(..),+   relationToString,                         -- used only internally+   MouseButton(..),+   marshalMouseButton, unmarshalMouseButton  -- used only internally+) where++import Foreign.C.Types+import Graphics.UI.GLUT.Raw++--------------------------------------------------------------------------------++-- | An opaque identifier for a top-level window or a subwindow.++newtype Window = Window CInt+   deriving ( Eq, Ord, Show )++--------------------------------------------------------------------------------++-- | A relation between a 'Graphics.UI.GLUT.Initialization.DisplayCapability'+-- and a numeric value.++data Relation+   = IsEqualTo        -- ^ Equal.+   | IsNotEqualTo     -- ^ Not equal.+   | IsLessThan       -- ^ Less than and preferring larger difference (the least+                      --   is best).+   | IsNotGreaterThan -- ^ Less than or equal and preferring larger difference+                      --   (the least is best).+   | IsGreaterThan    -- ^ Greater than and preferring larger differences (the+                      --   most is best).+   | IsAtLeast        -- ^ Greater than or equal and preferring more instead of+                      --   less. This relation is useful for allocating+                      --   resources like color precision or depth buffer+                      --   precision where the maximum precision is generally+                      --   preferred. Contrast with 'IsNotLessThan' relation.+   | IsNotLessThan    -- ^ Greater than or equal but preferring less instead of+                      --   more. This relation is useful for allocating+                      --   resources such as stencil bits or auxillary color+                      --   buffers where you would rather not over-allocate.+   deriving ( Eq, Ord, Show )++relationToString :: Relation -> String+relationToString IsEqualTo        = "="+relationToString IsNotEqualTo     = "!="+relationToString IsLessThan       = "<"+relationToString IsNotGreaterThan = "<="+relationToString IsGreaterThan    = ">"+relationToString IsAtLeast        = ">="+relationToString IsNotLessThan    = "~"++--------------------------------------------------------------------------------++-- | Mouse buttons, including a wheel++data MouseButton+   = LeftButton+   | MiddleButton+   | RightButton+   | WheelUp+   | WheelDown+   | AdditionalButton Int+   deriving ( Eq, Ord, Show )++marshalMouseButton :: MouseButton -> CInt+marshalMouseButton x = case x of+   LeftButton -> glut_LEFT_BUTTON+   MiddleButton -> glut_MIDDLE_BUTTON+   RightButton -> glut_RIGHT_BUTTON+   WheelUp -> glut_WHEEL_UP+   WheelDown -> glut_WHEEL_DOWN+   AdditionalButton b -> fromIntegral b++unmarshalMouseButton :: CInt -> MouseButton+unmarshalMouseButton x+   | x == glut_LEFT_BUTTON = LeftButton+   | x == glut_MIDDLE_BUTTON = MiddleButton+   | x == glut_RIGHT_BUTTON = RightButton+   | x == glut_WHEEL_UP = WheelUp+   | x == glut_WHEEL_DOWN = WheelDown+   | otherwise = AdditionalButton (fromIntegral x)++glut_WHEEL_UP :: CInt+glut_WHEEL_UP = 3++glut_WHEEL_DOWN :: CInt+glut_WHEEL_DOWN = 4
+ src/Graphics/UI/GLUT/Window.hs view
@@ -0,0 +1,502 @@+--------------------------------------------------------------------------------+-- |+-- Module      :  Graphics.UI.GLUT.Window+-- Copyright   :  (c) Sven Panne 2002-2013+-- License     :  BSD3+--+-- Maintainer  :  Sven Panne <svenpanne@gmail.com>+-- Stability   :  stable+-- Portability :  portable+--+-- GLUT supports two types of windows: top-level windows and subwindows. Both+-- types support OpenGL rendering and GLUT callbacks. There is a single+-- identifier space for both types of windows.+--+--------------------------------------------------------------------------------++module Graphics.UI.GLUT.Window (+   -- * Window identifiers+   Window,++   -- * Creating and destroying (sub-)windows++   -- $CreatingAndDestroyingSubWindows+   createWindow, createSubWindow, destroyWindow,+   parentWindow, numSubWindows,++   -- * Manipulating the /current window/+   currentWindow,++   -- * Re-displaying and double buffer management+   postRedisplay, swapBuffers,++   -- * Changing the window geometry++   -- $ChangingTheWindowGeometry+   windowPosition, windowSize, fullScreen, fullScreenToggle, leaveFullScreen,++   -- * Manipulating the stacking order++   -- $ManipulatingTheStackingOrder+   pushWindow, popWindow,++   -- * Managing a window\'s display status+   WindowStatus(..), windowStatus,++   -- * Changing the window\/icon title++   -- $ChangingTheWindowIconTitle+   windowTitle, iconTitle,++   -- * Cursor management+   Cursor(..), cursor, pointerPosition+) where++import Foreign.C.String+import Foreign.C.Types+import Graphics.Rendering.OpenGL ( Position(..), Size(..)+                                 , StateVar, makeStateVar+                                 , GettableStateVar, makeGettableStateVar+                                 , SettableStateVar, makeSettableStateVar )+import Graphics.UI.GLUT.QueryUtils+import Graphics.UI.GLUT.Raw+import Graphics.UI.GLUT.Types++--------------------------------------------------------------------------------++-- $CreatingAndDestroyingSubWindows+-- Each created window has a unique associated OpenGL context. State changes to+-- a window\'s associated OpenGL context can be done immediately after the+-- window is created.+--+-- The /display state/ of a window is initially for the window to be shown. But+-- the window\'s /display state/ is not actually acted upon until+-- 'Graphics.UI.GLUT.Begin.mainLoop' is entered. This means until+-- 'Graphics.UI.GLUT.Begin.mainLoop' is called, rendering to a created window is+-- ineffective because the window can not yet be displayed.+--+-- The value returned by 'createWindow' and 'createSubWindow' is a unique+-- identifier for the window, which can be used with 'currentWindow'.++-- | Create a top-level window. The given name will be provided to the window+-- system as the window\'s name. The intent is that the window system will label+-- the window with the name.Implicitly, the /current window/ is set to the newly+-- created window.+--+-- /X Implementation Notes:/ The proper X Inter-Client Communication Conventions+-- Manual (ICCCM) top-level properties are established. The @WM_COMMAND@+-- property that lists the command line used to invoke the GLUT program is only+-- established for the first window created.++createWindow+   :: String    -- ^ The window name+   -> IO Window -- ^ The identifier for the newly created window+createWindow name = fmap Window $ withCString name glutCreateWindow++--------------------------------------------------------------------------------++-- | Create a subwindow of the identified window with the given relative+-- position and size. Implicitly, the /current window/ is set to the+-- newly created subwindow. Subwindows can be nested arbitrarily deep.++createSubWindow+   :: Window    -- ^ Identifier of the subwindow\'s parent window.+   -> Position  -- ^ Window position in pixels relative to parent window\'s+                --   origin.+   -> Size      -- ^ Window size in pixels+   -> IO Window -- ^ The identifier for the newly created subwindow+createSubWindow (Window win) (Position x y) (Size w h) =+   fmap Window $+      glutCreateSubWindow win+                          (fromIntegral x) (fromIntegral y)+                          (fromIntegral w) (fromIntegral h)++--------------------------------------------------------------------------------++-- | Contains the /current window\'s/ parent. If the /current window/ is a+-- top-level window, 'Nothing' is returned.++parentWindow :: GettableStateVar (Maybe Window)+parentWindow =+   makeGettableStateVar $+      getWindow (simpleGet Window glut_WINDOW_PARENT)++--------------------------------------------------------------------------------++-- | Contains the number of subwindows the /current window/ has, not counting+-- children of children.++numSubWindows :: GettableStateVar Int+numSubWindows =+   makeGettableStateVar $+      simpleGet fromIntegral glut_WINDOW_NUM_CHILDREN++--------------------------------------------------------------------------------++-- | Destroy the specified window and the window\'s associated OpenGL context,+-- logical colormap (if the window is color index), and overlay and related+-- state (if an overlay has been established). Any subwindows of the destroyed+-- window are also destroyed by 'destroyWindow'. If the specified window was the+-- /current window/, the /current window/ becomes invalid ('currentWindow' will+-- contain 'Nothing').++destroyWindow :: Window -> IO ()+destroyWindow (Window win) = glutDestroyWindow win++--------------------------------------------------------------------------------++-- | Controls the /current window/. It does /not/ affect the /layer in use/ for+-- the window; this is done using 'Graphics.UI.GLUT.Overlay.layerInUse'.+-- Contains 'Nothing' if no windows exist or the previously /current window/ was+-- destroyed. Setting the /current window/ to 'Nothing' is a no-op.++currentWindow :: StateVar (Maybe Window)+currentWindow =+   makeStateVar+      (getWindow (fmap Window glutGetWindow))+      (maybe (return ()) (\(Window win) -> glutSetWindow win))++getWindow :: IO Window -> IO (Maybe Window)+getWindow act = do+   win <- act+   return $ if win == Window 0 then Nothing else Just win++--------------------------------------------------------------------------------++-- | Mark the normal plane of given window (or the /current window/, if none+-- is supplied) as needing to be redisplayed. The next iteration through+-- 'Graphics.UI.GLUT.Begin.mainLoop', the window\'s display callback will be+-- called to redisplay the window\'s normal plane. Multiple calls to+-- 'postRedisplay' before the next display callback opportunity generates only a+-- single redisplay callback. 'postRedisplay' may be called within a window\'s+-- display or overlay display callback to re-mark that window for redisplay.+--+-- Logically, normal plane damage notification for a window is treated as a+-- 'postRedisplay' on the damaged window. Unlike damage reported by the window+-- system, 'postRedisplay' will /not/ set to true the normal plane\'s damaged+-- status (see 'Graphics.UI.GLUT.State.damaged').+--+-- Also, see 'Graphics.UI.GLUT.Overlay.postOverlayRedisplay'.++postRedisplay :: Maybe Window -> IO ()+postRedisplay = maybe glutPostRedisplay (\(Window win) -> glutPostWindowRedisplay win)++-- | Mark the normal plane of the given window as needing to be redisplayed,+-- otherwise the same as 'postRedisplay'.+--+-- The advantage of this routine is that it saves the cost of using+-- 'currentWindow' (entailing an expensive OpenGL context switch), which is+-- particularly useful when multiple windows need redisplays posted at the same+-- time.++--------------------------------------------------------------------------------++-- | Perform a buffer swap on the /layer in use/ for the /current window/.+-- Specifically, 'swapBuffers' promotes the contents of the back buffer of the+-- /layer in use/ of the /current window/ to become the contents of the front+-- buffer. The contents of the back buffer then become undefined. The update+-- typically takes place during the vertical retrace of the monitor, rather than+-- immediately after 'swapBuffers' is called.+--+-- An implicit 'Graphics.Rendering.OpenGL.GL.FlushFinish.flush' is done by+-- 'swapBuffers' before it returns. Subsequent OpenGL commands can be issued+-- immediately after calling 'swapBuffers', but are not executed until the+-- buffer exchange is completed.+--+-- If the /layer in use/ is not double buffered, 'swapBuffers' has no effect.++swapBuffers :: IO ()+swapBuffers = glutSwapBuffers++--------------------------------------------------------------------------------++-- $ChangingTheWindowGeometry+-- Note that the requests by 'windowPosition', 'windowSize', and 'fullScreen'+-- are not processed immediately. A request is executed after returning to the+-- main event loop. This allows multiple requests to the same window to be+-- coalesced.+--+-- 'windowPosition' and 'windowSize' requests on a window will disable the full+-- screen status of the window.++--------------------------------------------------------------------------------++-- | Controls the position of the /current window/. For top-level windows,+-- parameters of 'Position' are pixel offsets from the screen origin. For+-- subwindows, the parameters are pixel offsets from the window\'s parent window+-- origin.+--+-- In the case of top-level windows, setting 'windowPosition' is considered only+-- a request for positioning the window. The window system is free to apply its+-- own policies to top-level window placement. The intent is that top-level+-- windows should be repositioned according to the value of 'windowPosition'.++windowPosition :: StateVar Position+windowPosition = makeStateVar getWindowPosition setWindowPosition++setWindowPosition :: Position -> IO ()+setWindowPosition (Position x y) =+   glutPositionWindow (fromIntegral x) (fromIntegral y)++getWindowPosition :: IO Position+getWindowPosition = do+   x <- simpleGet fromIntegral glut_WINDOW_X+   y <- simpleGet fromIntegral glut_WINDOW_Y+   return $ Position x y++--------------------------------------------------------------------------------++-- | Controls the size of the /current window/. The parameters of 'Size' are+-- size extents in pixels. The width and height must be positive values.+--+-- In the case of top-level windows, setting 'windowSize' is considered only a+-- request for sizing the window. The window system is free to apply its own+-- policies to top-level window sizing. The intent is that top-level windows+-- should be reshaped according to the value of 'windowSize'. Whether a reshape+-- actually takes effect and, if so, the reshaped dimensions are reported to the+-- program by a reshape callback.++windowSize :: StateVar Size+windowSize = makeStateVar getWindowSize setWindowSize++setWindowSize :: Size -> IO ()+setWindowSize (Size w h) =+   glutReshapeWindow (fromIntegral w) (fromIntegral h)++getWindowSize :: IO Size+getWindowSize = do+   w <- simpleGet fromIntegral glut_WINDOW_WIDTH+   h <- simpleGet fromIntegral glut_WINDOW_HEIGHT+   return $ Size w h++--------------------------------------------------------------------------------++-- | Request that the /current window/ be made full screen. The exact semantics+-- of what full screen means may vary by window system. The intent is to make+-- the window as large as possible and disable any window decorations or borders+-- added the window system. The window width and height are not guaranteed to be+-- the same as the screen width and height, but that is the intent of making a+-- window full screen.+--+-- 'fullScreen' is defined to work only on top-level windows.+--+-- /X Implementation Notes:/ In the X implementation of GLUT, full screen is+-- implemented by sizing and positioning the window to cover the entire screen+-- and posting the @_MOTIF_WM_HINTS@ property on the window requesting+-- absolutely no decorations. Non-Motif window managers may not respond to+-- @_MOTIF_WM_HINTS@.++fullScreen :: IO ()+fullScreen = glutFullScreen++--------------------------------------------------------------------------------++-- | (/freeglut only/) Toggle between windowed and full screen mode.++fullScreenToggle :: IO ()+fullScreenToggle = glutFullScreenToggle++--------------------------------------------------------------------------------++-- | (/freeglut only/) If we are in full screen mode, resize the current window+-- back to its original size.++leaveFullScreen :: IO ()+leaveFullScreen = glutLeaveFullScreen++--------------------------------------------------------------------------------++-- $ManipulatingTheStackingOrder+-- 'pushWindow' and 'popWindow' work on both top-level windows and subwindows.+-- The effect of pushing and popping windows does not take place immediately.+-- Instead the push or pop is saved for execution upon return to the GLUT event+-- loop. Subsequent pop or push requests on a window replace the previously+-- saved request for that window. The effect of pushing and popping top-level+-- windows is subject to the window system\'s policy for restacking windows.++-- | Change the stacking order of the /current window/ relative to its siblings+-- (lowering it).++pushWindow :: IO ()+pushWindow = glutPushWindow++-- | Change the stacking order of the /current window/ relative to its siblings,+-- bringing the /current window/ closer to the top.++popWindow :: IO ()+popWindow = glutPopWindow++--------------------------------------------------------------------------------++-- | The display status of a window.++data WindowStatus+   = Shown+   | Hidden+   | Iconified+   deriving ( Eq, Ord, Show )++-- | Controls the display status of the /current window/.+--+-- Note that the effect of showing, hiding, and iconifying windows does not take+-- place immediately. Instead the requests are saved for execution upon return+-- to the GLUT event loop. Subsequent show, hide, or iconification requests on a+-- window replace the previously saved request for that window. The effect of+-- hiding, showing, or iconifying top-level windows is subject to the window+-- system\'s policy for displaying windows. Subwindows can\'t be iconified.++windowStatus :: SettableStateVar WindowStatus+windowStatus = makeSettableStateVar setStatus+   where setStatus Shown     = glutShowWindow+         setStatus Hidden    = glutHideWindow+         setStatus Iconified = glutIconifyWindow++--------------------------------------------------------------------------------++-- $ChangingTheWindowIconTitle+-- 'windowTitle' and 'iconTitle' should be set only when the /current+-- window/ is a top-level window. Upon creation of a top-level window, the+-- window and icon names are determined by the name given to 'createWindow'.+-- Once created, setting 'windowTitle' and 'iconTitle' can change the window and+-- icon names respectively of top-level windows. Each call requests the window+-- system change the title appropriately. Requests are not buffered or+-- coalesced. The policy by which the window and icon name are displayed is+-- window system dependent.++-- | Controls the window title of the /current top-level window/.++windowTitle :: SettableStateVar String+windowTitle =+   makeSettableStateVar $ \name ->+      withCString name glutSetWindowTitle++-- | Controls the icon title of the /current top-level window/.++iconTitle :: SettableStateVar String+iconTitle =+   makeSettableStateVar $ \name ->+      withCString name glutSetIconTitle++--------------------------------------------------------------------------------++-- | The different cursor images GLUT supports.++data Cursor+   = RightArrow        -- ^ Arrow pointing up and to the right.+   | LeftArrow         -- ^ Arrow pointing up and to the left.+   | Info              -- ^ Pointing hand.+   | Destroy           -- ^ Skull & cross bones.+   | Help              -- ^ Question mark.+   | Cycle             -- ^ Arrows rotating in a circle.+   | Spray             -- ^ Spray can.+   | Wait              -- ^ Wrist watch.+   | Text              -- ^ Insertion point cursor for text.+   | Crosshair         -- ^ Simple cross-hair.+   | UpDown            -- ^ Bi-directional pointing up & down.+   | LeftRight         -- ^ Bi-directional pointing left & right.+   | TopSide           -- ^ Arrow pointing to top side.+   | BottomSide        -- ^ Arrow pointing to bottom side.+   | LeftSide          -- ^ Arrow pointing to left side.+   | RightSide         -- ^ Arrow pointing to right side.+   | TopLeftCorner     -- ^ Arrow pointing to top-left corner.+   | TopRightCorner    -- ^ Arrow pointing to top-right corner.+   | BottomRightCorner -- ^ Arrow pointing to bottom-left corner.+   | BottomLeftCorner  -- ^ Arrow pointing to bottom-right corner.+   | Inherit           -- ^ Use parent\'s cursor.+   | None              -- ^ Invisible cursor.+   | FullCrosshair     -- ^ Full-screen cross-hair cursor (if possible, otherwise 'Crosshair').+   deriving ( Eq, Ord, Show )++marshalCursor :: Cursor -> CInt+marshalCursor x = case x of+   RightArrow -> glut_CURSOR_RIGHT_ARROW+   LeftArrow -> glut_CURSOR_LEFT_ARROW+   Info -> glut_CURSOR_INFO+   Destroy -> glut_CURSOR_DESTROY+   Help -> glut_CURSOR_HELP+   Cycle -> glut_CURSOR_CYCLE+   Spray -> glut_CURSOR_SPRAY+   Wait -> glut_CURSOR_WAIT+   Text -> glut_CURSOR_TEXT+   Crosshair -> glut_CURSOR_CROSSHAIR+   UpDown -> glut_CURSOR_UP_DOWN+   LeftRight -> glut_CURSOR_LEFT_RIGHT+   TopSide -> glut_CURSOR_TOP_SIDE+   BottomSide -> glut_CURSOR_BOTTOM_SIDE+   LeftSide -> glut_CURSOR_LEFT_SIDE+   RightSide -> glut_CURSOR_RIGHT_SIDE+   TopLeftCorner -> glut_CURSOR_TOP_LEFT_CORNER+   TopRightCorner -> glut_CURSOR_TOP_RIGHT_CORNER+   BottomRightCorner -> glut_CURSOR_BOTTOM_RIGHT_CORNER+   BottomLeftCorner -> glut_CURSOR_BOTTOM_LEFT_CORNER+   Inherit -> glut_CURSOR_INHERIT+   None -> glut_CURSOR_NONE+   FullCrosshair -> glut_CURSOR_FULL_CROSSHAIR++unmarshalCursor :: CInt -> Cursor+unmarshalCursor x+   | x == glut_CURSOR_RIGHT_ARROW = RightArrow+   | x == glut_CURSOR_LEFT_ARROW = LeftArrow+   | x == glut_CURSOR_INFO = Info+   | x == glut_CURSOR_DESTROY = Destroy+   | x == glut_CURSOR_HELP = Help+   | x == glut_CURSOR_CYCLE = Cycle+   | x == glut_CURSOR_SPRAY = Spray+   | x == glut_CURSOR_WAIT = Wait+   | x == glut_CURSOR_TEXT = Text+   | x == glut_CURSOR_CROSSHAIR = Crosshair+   | x == glut_CURSOR_UP_DOWN = UpDown+   | x == glut_CURSOR_LEFT_RIGHT = LeftRight+   | x == glut_CURSOR_TOP_SIDE = TopSide+   | x == glut_CURSOR_BOTTOM_SIDE = BottomSide+   | x == glut_CURSOR_LEFT_SIDE = LeftSide+   | x == glut_CURSOR_RIGHT_SIDE = RightSide+   | x == glut_CURSOR_TOP_LEFT_CORNER = TopLeftCorner+   | x == glut_CURSOR_TOP_RIGHT_CORNER = TopRightCorner+   | x == glut_CURSOR_BOTTOM_RIGHT_CORNER = BottomRightCorner+   | x == glut_CURSOR_BOTTOM_LEFT_CORNER = BottomLeftCorner+   | x == glut_CURSOR_INHERIT = Inherit+   | x == glut_CURSOR_NONE = None+   | x == glut_CURSOR_FULL_CROSSHAIR = FullCrosshair+   | otherwise = error ("unmarshalCursor: illegal value " ++ show x)++--------------------------------------------------------------------------------++-- | Change the cursor image of the /current window/. Each call requests the+-- window system change the cursor appropriately. The cursor image when a window+-- is created is 'Inherit'. The exact cursor images used are implementation+-- dependent. The intent is for the image to convey the meaning of the cursor+-- name. For a top-level window, 'Inherit' uses the default window system+-- cursor.+--+-- /X Implementation Notes:/ GLUT for X uses SGI\'s @_SGI_CROSSHAIR_CURSOR@+-- convention to access a full-screen cross-hair cursor if possible.++cursor :: StateVar Cursor+cursor = makeStateVar getCursor setCursor++setCursor :: Cursor -> IO ()+setCursor = glutSetCursor . marshalCursor++getCursor :: IO Cursor+getCursor = simpleGet unmarshalCursor glut_WINDOW_CURSOR++--------------------------------------------------------------------------------++-- | Setting 'pointerPosition' warps the window system\'s pointer to a new+-- location relative to the origin of the /current window/ by the specified+-- pixel offset, which may be negative. The warp is done immediately.+--+-- If the pointer would be warped outside the screen\'s frame buffer region, the+-- location will be clamped to the nearest screen edge. The window system is+-- allowed to further constrain the pointer\'s location in window system+-- dependent ways.+--+-- Good advice from Xlib\'s @XWarpPointer@ man page: \"There is seldom any+-- reason for calling this function. The pointer should normally be left to the+-- user.\"++pointerPosition :: SettableStateVar Position+pointerPosition =+   makeSettableStateVar $ \(Position x y) ->+      glutWarpPointer (fromIntegral x) (fromIntegral y)