GLUT 2.4.0.0 → 2.5.0.0

raw patch · 204 files changed

+17627/−17552 lines, 204 filesdep ~OpenGLdep ~OpenGLRawbinary-addedPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: OpenGL, OpenGLRaw

API changes (from Hackage documentation)

Files

• GLUT.cabal +185/−171
• Graphics/UI/GLUT.hs +386/−386
• Graphics/UI/GLUT/Begin.hs +102/−98
• Graphics/UI/GLUT/Callbacks.hs +47/−47
• Graphics/UI/GLUT/Callbacks/Global.hs +114/−114
• Graphics/UI/GLUT/Callbacks/Registration.hs +160/−160
• Graphics/UI/GLUT/Callbacks/Window.hs +838/−838
• Graphics/UI/GLUT/Colormap.hs +110/−110
• Graphics/UI/GLUT/Debugging.hs +37/−37
• Graphics/UI/GLUT/DeviceControl.hs +122/−122
• Graphics/UI/GLUT/Fonts.hs +183/−183
• Graphics/UI/GLUT/GameMode.hs +191/−191
• Graphics/UI/GLUT/Initialization.hs +773/−773
• Graphics/UI/GLUT/Menu.hs +248/−248
• Graphics/UI/GLUT/Objects.hs +337/−337
• Graphics/UI/GLUT/Overlay.hs +168/−168
• Graphics/UI/GLUT/QueryUtils.hs +35/−35
• Graphics/UI/GLUT/Raw.hs +28/−28
• Graphics/UI/GLUT/Raw/APIEntry.hs +51/−51
• Graphics/UI/GLUT/Raw/Callbacks.hs +201/−201
• Graphics/UI/GLUT/Raw/Fonts.hs +29/−29
• Graphics/UI/GLUT/Raw/Functions.hs +311/−311
• Graphics/UI/GLUT/Raw/Tokens.hs +613/−613
• Graphics/UI/GLUT/State.hs +382/−382
• Graphics/UI/GLUT/Types.hs +104/−104
• Graphics/UI/GLUT/Window.hs +494/−494
• README +0/−4
• README.md +1/−0
• cbits/HsGLUT.c +154/−154
• examples/BOGLGP/Chapter01/Makefile +1/−0
• examples/BOGLGP/Chapter01/OnYourOwn1.hs +111/−111
• examples/BOGLGP/Chapter01/Simple.hs +111/−111
• examples/BOGLGP/Chapter02/Makefile +1/−0
• examples/BOGLGP/Chapter02/OnYourOwn1.hs +230/−230
• examples/BOGLGP/Chapter02/OpenGLApplication.hs +230/−230
• examples/BOGLGP/Chapter03/Lines.hs +210/−210
• examples/BOGLGP/Chapter03/Makefile +1/−0
• examples/BOGLGP/Chapter03/OnYourOwn1.hs +217/−217
• examples/BOGLGP/Chapter03/Points.hs +196/−196
• examples/BOGLGP/Chapter03/Polygons.hs +230/−230
• examples/BOGLGP/Chapter03/TrianglesQuads.hs +294/−294
• examples/BOGLGP/Makefile +2/−0
• examples/Makefile +2/−0
• examples/Misc/ARBOcclude.hs +193/−193
• examples/Misc/ExtractContours.hs +117/−117
• examples/Misc/Gears.hs +301/−301
• examples/Misc/Makefile +1/−0
• examples/Misc/Pitfall14.hs +33/−33
• examples/Misc/SmoothOpenGL3.hs +272/−266
• examples/Misc/Triangulate.hs +122/−122
• examples/OrangeBook/Makefile +2/−0
• examples/OrangeBook/ogl2brick/Brick.hs +370/−368
• examples/OrangeBook/ogl2brick/Makefile +1/−0
• examples/RedBook/00-README +0/−189
• examples/RedBook/AAIndex.hs +0/−104
• examples/RedBook/AARGB.hs +0/−104
• examples/RedBook/AccAnti.hs +0/−132
• examples/RedBook/AccPersp.hs +0/−166
• examples/RedBook/Alpha.hs +0/−91
• examples/RedBook/Alpha3D.hs +0/−124
• examples/RedBook/BezCurve.hs +0/−67
• examples/RedBook/BezMesh.hs +0/−84
• examples/RedBook/BezSurf.hs +0/−79
• examples/RedBook/BlendEqn.hs +0/−95
• examples/RedBook/Checker.hs +0/−101
• examples/RedBook/Clip.hs +0/−63
• examples/RedBook/ColorMat.hs +0/−94
• examples/RedBook/ColorMatrix.hs +0/−65
• examples/RedBook/ColorTable.hs +0/−62
• examples/RedBook/Combiner.hs +0/−236
• examples/RedBook/Convolution.hs +0/−83
• examples/RedBook/Cube.hs +0/−56
• examples/RedBook/CubeMap.hs +0/−118
• examples/RedBook/DList.hs +0/−85
• examples/RedBook/DOF.hs +0/−182
• examples/RedBook/Data/leeds.bin binary
• examples/RedBook/Double.hs +0/−76
• examples/RedBook/DrawF.hs +0/−62
• examples/RedBook/Feedback.hs +0/−77
• examples/RedBook/Fog.hs +0/−90
• examples/RedBook/FogCoord.hs +0/−122
• examples/RedBook/FogIndex.hs +0/−76
• examples/RedBook/Font.hs +0/−127
• examples/RedBook/Hello.hs +0/−55
• examples/RedBook/Histogram.hs +0/−85
• examples/RedBook/Image.hs +0/−116
• examples/RedBook/Light.hs +0/−62
• examples/RedBook/Lines.hs +0/−88
• examples/RedBook/MVArray.hs +0/−87
• examples/RedBook/Material.hs +0/−149
• examples/RedBook/Minmax.hs +0/−64
• examples/RedBook/Mipmap.hs +0/−97
• examples/RedBook/Model.hs +0/−86
• examples/RedBook/MoveLight.hs +0/−85
• examples/RedBook/MultiTex.hs +0/−111
• examples/RedBook/Multisamp.hs +0/−137
• examples/RedBook/PickDepth.hs +0/−126
• examples/RedBook/PickSquare.hs +0/−121
• examples/RedBook/Planet.hs +0/−83
• examples/RedBook/PointP.hs +0/−152
• examples/RedBook/PolyOff.hs +0/−151
• examples/RedBook/Polys.hs +0/−84
• examples/RedBook/Quadric.hs +0/−106
• examples/RedBook/ReadImage.hs +0/−65
• examples/RedBook/Robot.hs +0/−89
• examples/RedBook/Scene.hs +0/−73
• examples/RedBook/Select.hs +0/−150
• examples/RedBook/ShadowMap.hs +0/−255
• examples/RedBook/Smooth.hs +0/−65
• examples/RedBook/Stencil.hs +0/−123
• examples/RedBook/Stroke.hs +0/−127
• examples/RedBook/SurfPoints.hs +0/−129
• examples/RedBook/Surface.hs +0/−112
• examples/RedBook/Teapots.hs +0/−226
• examples/RedBook/Tess.hs +0/−117
• examples/RedBook/TessWind.hs +0/−195
• examples/RedBook/TexBind.hs +0/−108
• examples/RedBook/TexGen.hs +0/−132
• examples/RedBook/TexProx.hs +0/−58
• examples/RedBook/TexSub.hs +0/−120
• examples/RedBook/Texture3D.hs +0/−94
• examples/RedBook/TextureSurf.hs +0/−99
• examples/RedBook/Torus.hs +0/−93
• examples/RedBook/Trim.hs +0/−107
• examples/RedBook/UnProject.hs +0/−54
• examples/RedBook/VArray.hs +0/−141
• examples/RedBook/Wrap.hs +0/−114
• examples/RedBook4/00-README +189/−0
• examples/RedBook4/AAIndex.hs +104/−0
• examples/RedBook4/AARGB.hs +104/−0
• examples/RedBook4/AccAnti.hs +132/−0
• examples/RedBook4/AccPersp.hs +166/−0
• examples/RedBook4/Alpha.hs +91/−0
• examples/RedBook4/Alpha3D.hs +124/−0
• examples/RedBook4/BezCurve.hs +67/−0
• examples/RedBook4/BezMesh.hs +84/−0
• examples/RedBook4/BezSurf.hs +79/−0
• examples/RedBook4/BlendEqn.hs +95/−0
• examples/RedBook4/Checker.hs +101/−0
• examples/RedBook4/Clip.hs +63/−0
• examples/RedBook4/ColorMat.hs +94/−0
• examples/RedBook4/ColorMatrix.hs +65/−0
• examples/RedBook4/ColorTable.hs +62/−0
• examples/RedBook4/Combiner.hs +236/−0
• examples/RedBook4/Convolution.hs +83/−0
• examples/RedBook4/Cube.hs +56/−0
• examples/RedBook4/CubeMap.hs +118/−0
• examples/RedBook4/DList.hs +85/−0
• examples/RedBook4/DOF.hs +182/−0
• examples/RedBook4/Data/leeds.bin binary
• examples/RedBook4/Double.hs +76/−0
• examples/RedBook4/DrawF.hs +62/−0
• examples/RedBook4/Feedback.hs +77/−0
• examples/RedBook4/Fog.hs +90/−0
• examples/RedBook4/FogCoord.hs +122/−0
• examples/RedBook4/FogIndex.hs +76/−0
• examples/RedBook4/Font.hs +127/−0
• examples/RedBook4/Hello.hs +55/−0
• examples/RedBook4/Histogram.hs +85/−0
• examples/RedBook4/Image.hs +116/−0
• examples/RedBook4/Light.hs +62/−0
• examples/RedBook4/Lines.hs +88/−0
• examples/RedBook4/MVArray.hs +87/−0
• examples/RedBook4/Makefile +4/−0
• examples/RedBook4/Material.hs +149/−0
• examples/RedBook4/Minmax.hs +64/−0
• examples/RedBook4/Mipmap.hs +97/−0
• examples/RedBook4/Model.hs +86/−0
• examples/RedBook4/MoveLight.hs +85/−0
• examples/RedBook4/MultiTex.hs +111/−0
• examples/RedBook4/Multisamp.hs +137/−0
• examples/RedBook4/PickDepth.hs +126/−0
• examples/RedBook4/PickSquare.hs +121/−0
• examples/RedBook4/Planet.hs +83/−0
• examples/RedBook4/PointP.hs +152/−0
• examples/RedBook4/PolyOff.hs +151/−0
• examples/RedBook4/Polys.hs +84/−0
• examples/RedBook4/Quadric.hs +106/−0
• examples/RedBook4/ReadImage.hs +65/−0
• examples/RedBook4/Robot.hs +89/−0
• examples/RedBook4/Scene.hs +73/−0
• examples/RedBook4/Select.hs +150/−0
• examples/RedBook4/ShadowMap.hs +255/−0
• examples/RedBook4/Smooth.hs +65/−0
• examples/RedBook4/Stencil.hs +123/−0
• examples/RedBook4/Stroke.hs +127/−0
• examples/RedBook4/SurfPoints.hs +129/−0
• examples/RedBook4/Surface.hs +112/−0
• examples/RedBook4/Teapots.hs +226/−0
• examples/RedBook4/Tess.hs +117/−0
• examples/RedBook4/TessWind.hs +195/−0
• examples/RedBook4/TexBind.hs +108/−0
• examples/RedBook4/TexGen.hs +132/−0
• examples/RedBook4/TexProx.hs +58/−0
• examples/RedBook4/TexSub.hs +120/−0
• examples/RedBook4/Texture3D.hs +94/−0
• examples/RedBook4/TextureSurf.hs +99/−0
• examples/RedBook4/Torus.hs +93/−0
• examples/RedBook4/Trim.hs +107/−0
• examples/RedBook4/UnProject.hs +54/−0
• examples/RedBook4/VArray.hs +141/−0
• examples/RedBook4/Wrap.hs +114/−0
• examples/examples.mk +37/−0
• include/HsGLUTExt.h +33/−33

@@ -1,171 +1,185 @@-name: GLUT-version: 2.4.0.0-license: BSD3-license-file: LICENSE-maintainer: 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-extra-source-files:-   README-   examples/BOGLGP/Chapter01/OnYourOwn1.hs-   examples/BOGLGP/Chapter01/Simple.hs-   examples/BOGLGP/Chapter02/OnYourOwn1.hs-   examples/BOGLGP/Chapter02/OpenGLApplication.hs-   examples/BOGLGP/Chapter03/Lines.hs-   examples/BOGLGP/Chapter03/OnYourOwn1.hs-   examples/BOGLGP/Chapter03/Points.hs-   examples/BOGLGP/Chapter03/Polygons.hs-   examples/BOGLGP/Chapter03/TrianglesQuads.hs-   examples/Misc/ARBOcclude.hs-   examples/Misc/ExtractContours.hs-   examples/Misc/Gears.hs-   examples/Misc/Pitfall14.hs-   examples/Misc/SmoothOpenGL3.hs-   examples/Misc/Triangulate.hs-   examples/OrangeBook/3Dlabs-License.txt-   examples/OrangeBook/ogl2brick/Brick.frag-   examples/OrangeBook/ogl2brick/Brick.hs-   examples/OrangeBook/ogl2brick/Brick.vert-   examples/RedBook/00-README-   examples/RedBook/AAIndex.hs-   examples/RedBook/AARGB.hs-   examples/RedBook/AccAnti.hs-   examples/RedBook/AccPersp.hs-   examples/RedBook/Alpha.hs-   examples/RedBook/Alpha3D.hs-   examples/RedBook/BezCurve.hs-   examples/RedBook/BezMesh.hs-   examples/RedBook/BezSurf.hs-   examples/RedBook/BlendEqn.hs-   examples/RedBook/Checker.hs-   examples/RedBook/Clip.hs-   examples/RedBook/ColorMat.hs-   examples/RedBook/ColorMatrix.hs-   examples/RedBook/ColorTable.hs-   examples/RedBook/Combiner.hs-   examples/RedBook/Convolution.hs-   examples/RedBook/Cube.hs-   examples/RedBook/CubeMap.hs-   examples/RedBook/DList.hs-   examples/RedBook/DOF.hs-   examples/RedBook/Data/leeds.bin-   examples/RedBook/Double.hs-   examples/RedBook/DrawF.hs-   examples/RedBook/Feedback.hs-   examples/RedBook/Fog.hs-   examples/RedBook/FogCoord.hs-   examples/RedBook/FogIndex.hs-   examples/RedBook/Font.hs-   examples/RedBook/Hello.hs-   examples/RedBook/Histogram.hs-   examples/RedBook/Image.hs-   examples/RedBook/Light.hs-   examples/RedBook/Lines.hs-   examples/RedBook/MVArray.hs-   examples/RedBook/Material.hs-   examples/RedBook/Minmax.hs-   examples/RedBook/Mipmap.hs-   examples/RedBook/Model.hs-   examples/RedBook/MoveLight.hs-   examples/RedBook/MultiTex.hs-   examples/RedBook/Multisamp.hs-   examples/RedBook/PickDepth.hs-   examples/RedBook/PickSquare.hs-   examples/RedBook/Planet.hs-   examples/RedBook/PointP.hs-   examples/RedBook/PolyOff.hs-   examples/RedBook/Polys.hs-   examples/RedBook/Quadric.hs-   examples/RedBook/ReadImage.hs-   examples/RedBook/Robot.hs-   examples/RedBook/Scene.hs-   examples/RedBook/Select.hs-   examples/RedBook/ShadowMap.hs-   examples/RedBook/Smooth.hs-   examples/RedBook/Stencil.hs-   examples/RedBook/Stroke.hs-   examples/RedBook/SurfPoints.hs-   examples/RedBook/Surface.hs-   examples/RedBook/Teapots.hs-   examples/RedBook/Tess.hs-   examples/RedBook/TessWind.hs-   examples/RedBook/TexBind.hs-   examples/RedBook/TexGen.hs-   examples/RedBook/TexProx.hs-   examples/RedBook/TexSub.hs-   examples/RedBook/Texture3D.hs-   examples/RedBook/TextureSurf.hs-   examples/RedBook/Torus.hs-   examples/RedBook/Trim.hs-   examples/RedBook/UnProject.hs-   examples/RedBook/VArray.hs-   examples/RedBook/Wrap.hs-   include/HsGLUTExt.h--flag split-base--flag UseNativeWindowsLibraries-   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,-      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-   if flag(split-base)-      build-depends: base >= 3 && < 5, array >= 0.3 && < 0.5, containers >= 0.3 && < 0.6-   else-      build-depends: base < 3-   build-depends: OpenGL == 2.8.*, OpenGLRaw == 1.3.*-   ghc-options: -Wall -O2-   if os(windows) && flag(UseNativeWindowsLibraries)-      cpp-options: "-DCALLCONV=stdcall"-      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+name: GLUT
+version: 2.5.0.0
+license: BSD3
+license-file: LICENSE
+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
+extra-source-files:
+   README.md
+   examples/BOGLGP/Chapter01/Makefile
+   examples/BOGLGP/Chapter01/OnYourOwn1.hs
+   examples/BOGLGP/Chapter01/Simple.hs
+   examples/BOGLGP/Chapter02/Makefile
+   examples/BOGLGP/Chapter02/OnYourOwn1.hs
+   examples/BOGLGP/Chapter02/OpenGLApplication.hs
+   examples/BOGLGP/Chapter03/Lines.hs
+   examples/BOGLGP/Chapter03/Makefile
+   examples/BOGLGP/Chapter03/OnYourOwn1.hs
+   examples/BOGLGP/Chapter03/Points.hs
+   examples/BOGLGP/Chapter03/Polygons.hs
+   examples/BOGLGP/Chapter03/TrianglesQuads.hs
+   examples/BOGLGP/Makefile
+   examples/Makefile
+   examples/Misc/ARBOcclude.hs
+   examples/Misc/ExtractContours.hs
+   examples/Misc/Gears.hs
+   examples/Misc/Makefile
+   examples/Misc/Pitfall14.hs
+   examples/Misc/SmoothOpenGL3.hs
+   examples/Misc/Triangulate.hs
+   examples/OrangeBook/3Dlabs-License.txt
+   examples/OrangeBook/Makefile
+   examples/OrangeBook/ogl2brick/Brick.frag
+   examples/OrangeBook/ogl2brick/Brick.hs
+   examples/OrangeBook/ogl2brick/Brick.vert
+   examples/OrangeBook/ogl2brick/Makefile
+   examples/RedBook4/00-README
+   examples/RedBook4/AAIndex.hs
+   examples/RedBook4/AARGB.hs
+   examples/RedBook4/AccAnti.hs
+   examples/RedBook4/AccPersp.hs
+   examples/RedBook4/Alpha.hs
+   examples/RedBook4/Alpha3D.hs
+   examples/RedBook4/BezCurve.hs
+   examples/RedBook4/BezMesh.hs
+   examples/RedBook4/BezSurf.hs
+   examples/RedBook4/BlendEqn.hs
+   examples/RedBook4/Checker.hs
+   examples/RedBook4/Clip.hs
+   examples/RedBook4/ColorMat.hs
+   examples/RedBook4/ColorMatrix.hs
+   examples/RedBook4/ColorTable.hs
+   examples/RedBook4/Combiner.hs
+   examples/RedBook4/Convolution.hs
+   examples/RedBook4/Cube.hs
+   examples/RedBook4/CubeMap.hs
+   examples/RedBook4/DList.hs
+   examples/RedBook4/DOF.hs
+   examples/RedBook4/Data/leeds.bin
+   examples/RedBook4/Double.hs
+   examples/RedBook4/DrawF.hs
+   examples/RedBook4/Feedback.hs
+   examples/RedBook4/Fog.hs
+   examples/RedBook4/FogCoord.hs
+   examples/RedBook4/FogIndex.hs
+   examples/RedBook4/Font.hs
+   examples/RedBook4/Hello.hs
+   examples/RedBook4/Histogram.hs
+   examples/RedBook4/Image.hs
+   examples/RedBook4/Light.hs
+   examples/RedBook4/Lines.hs
+   examples/RedBook4/MVArray.hs
+   examples/RedBook4/Makefile
+   examples/RedBook4/Material.hs
+   examples/RedBook4/Minmax.hs
+   examples/RedBook4/Mipmap.hs
+   examples/RedBook4/Model.hs
+   examples/RedBook4/MoveLight.hs
+   examples/RedBook4/MultiTex.hs
+   examples/RedBook4/Multisamp.hs
+   examples/RedBook4/PickDepth.hs
+   examples/RedBook4/PickSquare.hs
+   examples/RedBook4/Planet.hs
+   examples/RedBook4/PointP.hs
+   examples/RedBook4/PolyOff.hs
+   examples/RedBook4/Polys.hs
+   examples/RedBook4/Quadric.hs
+   examples/RedBook4/ReadImage.hs
+   examples/RedBook4/Robot.hs
+   examples/RedBook4/Scene.hs
+   examples/RedBook4/Select.hs
+   examples/RedBook4/ShadowMap.hs
+   examples/RedBook4/Smooth.hs
+   examples/RedBook4/Stencil.hs
+   examples/RedBook4/Stroke.hs
+   examples/RedBook4/SurfPoints.hs
+   examples/RedBook4/Surface.hs
+   examples/RedBook4/Teapots.hs
+   examples/RedBook4/Tess.hs
+   examples/RedBook4/TessWind.hs
+   examples/RedBook4/TexBind.hs
+   examples/RedBook4/TexGen.hs
+   examples/RedBook4/TexProx.hs
+   examples/RedBook4/TexSub.hs
+   examples/RedBook4/Texture3D.hs
+   examples/RedBook4/TextureSurf.hs
+   examples/RedBook4/Torus.hs
+   examples/RedBook4/Trim.hs
+   examples/RedBook4/UnProject.hs
+   examples/RedBook4/VArray.hs
+   examples/RedBook4/Wrap.hs
+   examples/examples.mk
+   include/HsGLUTExt.h
+
+flag split-base
+
+flag UseNativeWindowsLibraries
+   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
+   if flag(split-base)
+      build-depends: base >= 3 && < 5, array >= 0.3 && < 0.5, containers >= 0.3 && < 0.6
+   else
+      build-depends: base < 3
+   build-depends: 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
+      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

@@ -1,386 +1,386 @@--------------------------------------------------------------------------------- |--- Module      :  Graphics.UI.GLUT--- Copyright   :  (c) Sven Panne 2002-2005--- License     :  BSD-style (see the file libraries/GLUT/LICENSE)------ Maintainer  :  sven.panne@aedion.de--- 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.+-----------------------------------------------------------------------------
+-- |
+-- 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.

@@ -1,98 +1,102 @@------------------------------------------------------------------------------------ |--- Module      :  Graphics.UI.GLUT.Begin--- Copyright   :  (c) Sven Panne 2002-2005--- License     :  BSD-style (see the file libraries/GLUT/LICENSE)------ Maintainer  :  sven.panne@aedion.de--- 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.-     ContinueExectuion-   deriving ( Eq, Ord, Show )--marshalActionOnWindowClose :: ActionOnWindowClose -> CInt-marshalActionOnWindowClose x = case x of-   Exit ->  glut_ACTION_EXIT-   MainLoopReturns -> glut_ACTION_GLUTMAINLOOP_RETURNS-   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 = ContinueExectuion-   | 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)+--------------------------------------------------------------------------------
+-- |
+-- 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)

@@ -1,47 +1,47 @@------------------------------------------------------------------------------------ |--- Module      :  Graphics.UI.GLUT.Callbacks--- Copyright   :  (c) Sven Panne 2002-2005--- License     :  BSD-style (see the file libraries/GLUT/LICENSE)------ Maintainer  :  sven.panne@aedion.de--- 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+--------------------------------------------------------------------------------
+-- |
+-- 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

@@ -1,114 +1,114 @@------------------------------------------------------------------------------------ |--- Module      :  Graphics.UI.GLUT.Callbacks.Global--- Copyright   :  (c) Sven Panne 2002-2005--- License     :  BSD-style (see the file libraries/GLUT/LICENSE)------ Maintainer  :  sven.panne@aedion.de--- 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+--------------------------------------------------------------------------------
+-- |
+-- 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

@@ -1,160 +1,160 @@-{-# OPTIONS_GHC -fno-cse #-}---- #hide------------------------------------------------------------------------------------ |--- Module      :  Graphics.UI.GLUT.Callbacks.Registration--- Copyright   :  (c) Sven Panne 2002-2005--- License     :  BSD-style (see the file libraries/GLUT/LICENSE)------ Maintainer  :  sven.panne@aedion.de--- 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-   | CloseCB   -- freeglut only-   | MouseWheelCB   -- freeglut only-   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+{-# 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
+   | CloseCB   -- freeglut only
+   | MouseWheelCB   -- freeglut only
+   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

@@ -1,838 +1,838 @@------------------------------------------------------------------------------------ |--- Module      :  Graphics.UI.GLUT.Callbacks.Window--- Copyright   :  (c) Sven Panne 2002-2005--- License     :  BSD-style (see the file libraries/GLUT/LICENSE)------ Maintainer  :  sven.panne@aedion.de--- Stability   :  stable--- Portability :  portable--------------------------------------------------------------------------------------module Graphics.UI.GLUT.Callbacks.Window (-   -- * Redisplay callbacks-   DisplayCallback, displayCallback, overlayDisplayCallback,--   -- * Reshape callback-   ReshapeCallback, reshapeCallback,--   -- * Callbacks for visibility changes-   Visibility(..), VisibilityCallback, visibilityCallback,-   WindowState(..), WindowStateCallback, windowStateCallback,--   -- * Window close callback-   CloseCallback, closeCallback,--   -- * 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-) where--import Data.Bits hiding ( shift )-import Data.Char-import Data.Maybe-import Foreign.C.Types-import Graphics.Rendering.OpenGL ( Position(..), Size(..)-                                 , SettableStateVar, makeSettableStateVar )-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))-------------------------------------------------------------------------------------- | 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------------------------------------------------------------------------------------type CloseCallback = IO ()--closeCallback :: SettableStateVar (Maybe CloseCallback)-closeCallback = makeSettableStateVar $-   setCallback CloseCB glutCloseFunc makeCloseFunc-------------------------------------------------------------------------------------- | 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-   | KeyUnknown Int-   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-   | 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))+--------------------------------------------------------------------------------
+-- |
+-- 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,
+
+   -- * Callbacks for visibility changes
+   Visibility(..), VisibilityCallback, visibilityCallback,
+   WindowState(..), WindowStateCallback, windowStateCallback,
+
+   -- * Window close callback
+   CloseCallback, closeCallback,
+
+   -- * 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
+) where
+
+import Data.Bits hiding ( shift )
+import Data.Char
+import Data.Maybe
+import Foreign.C.Types
+import Graphics.Rendering.OpenGL ( Position(..), Size(..)
+                                 , SettableStateVar, makeSettableStateVar )
+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))
+
+--------------------------------------------------------------------------------
+
+-- | 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
+
+--------------------------------------------------------------------------------
+
+type CloseCallback = IO ()
+
+closeCallback :: SettableStateVar (Maybe CloseCallback)
+closeCallback = makeSettableStateVar $
+   setCallback CloseCB glutCloseFunc makeCloseFunc
+
+--------------------------------------------------------------------------------
+
+-- | 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
+   | KeyUnknown Int
+   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
+   | 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))

@@ -1,110 +1,110 @@------------------------------------------------------------------------------------ |--- Module      :  Graphics.UI.GLUT.Colormap--- Copyright   :  (c) Sven Panne 2002-2005--- License     :  BSD-style (see the file libraries/GLUT/LICENSE)------ Maintainer  :  sven.panne@aedion.de--- 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+--------------------------------------------------------------------------------
+-- |
+-- 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

@@ -1,37 +1,37 @@------------------------------------------------------------------------------------ |--- Module      :  Graphics.UI.GLUT.Debugging--- Copyright   :  (c) Sven Panne 2002-2005--- License     :  BSD-style (see the file libraries/GLUT/LICENSE)------ Maintainer  :  sven.panne@aedion.de--- 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)+--------------------------------------------------------------------------------
+-- |
+-- 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)

@@ -1,122 +1,122 @@------------------------------------------------------------------------------------ |--- Module      :  Graphics.UI.GLUT.DeviceControl--- Copyright   :  (c) Sven Panne 2002-2005--- License     :  BSD-style (see the file libraries/GLUT/LICENSE)------ Maintainer  :  sven.panne@aedion.de--- 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+--------------------------------------------------------------------------------
+-- |
+-- 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

@@ -1,183 +1,183 @@------------------------------------------------------------------------------------ |--- Module      :  Graphics.UI.GLUT.Fonts--- Copyright   :  (c) Sven Panne 2002-2005--- License     :  BSD-style (see the file libraries/GLUT/LICENSE)------ Maintainer  :  sven.panne@aedion.de--- 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 ( GLint, GLfloat )-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-------------------------------------------------------------------------------------- | 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 ()--marhshalBitmapFont :: BitmapFont -> IO GLUTbitmapFont-marhshalBitmapFont 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-------------------------------------------------------------------------------------- | 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 ()--marhshalStrokeFont :: StrokeFont -> IO GLUTstrokeFont-marhshalStrokeFont x = case x of-   Roman -> hs_GLUT_marshalStrokeFont 0-   MonoRoman -> hs_GLUT_marshalStrokeFont 1------------------------------------------------------------------------------------bitmapString :: BitmapFont -> String -> IO ()-bitmapString f s = do-   i <- marhshalBitmapFont 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 <- marhshalStrokeFont 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 <- marhshalBitmapFont 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 <- marhshalStrokeFont f-   fmap fromIntegral $ withCString s (glutStrokeLength i . castPtr)------------------------------------------------------------------------------------bitmapHeight :: BitmapFont -- ^ Bitmap font to use.-             -> IO GLfloat -- ^ Height in pixels.-bitmapHeight f = fmap fromIntegral $ glutBitmapHeight =<< marhshalBitmapFont f------------------------------------------------------------------------------------strokeHeight :: StrokeFont -- ^ Stroke font to use.-             -> IO GLfloat -- ^ Height in units.-strokeHeight f = glutStrokeHeight =<< marhshalStrokeFont f+--------------------------------------------------------------------------------
+-- |
+-- 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 ( GLint, GLfloat )
+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
+
+--------------------------------------------------------------------------------
+
+-- | 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 ()
+
+marhshalBitmapFont :: BitmapFont -> IO GLUTbitmapFont
+marhshalBitmapFont 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
+
+--------------------------------------------------------------------------------
+
+-- | 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 ()
+
+marhshalStrokeFont :: StrokeFont -> IO GLUTstrokeFont
+marhshalStrokeFont x = case x of
+   Roman -> hs_GLUT_marshalStrokeFont 0
+   MonoRoman -> hs_GLUT_marshalStrokeFont 1
+
+--------------------------------------------------------------------------------
+
+bitmapString :: BitmapFont -> String -> IO ()
+bitmapString f s = do
+   i <- marhshalBitmapFont 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 <- marhshalStrokeFont 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 <- marhshalBitmapFont 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 <- marhshalStrokeFont f
+   fmap fromIntegral $ withCString s (glutStrokeLength i . castPtr)
+
+--------------------------------------------------------------------------------
+
+bitmapHeight :: BitmapFont -- ^ Bitmap font to use.
+             -> IO GLfloat -- ^ Height in pixels.
+bitmapHeight f = fmap fromIntegral $ glutBitmapHeight =<< marhshalBitmapFont f
+
+--------------------------------------------------------------------------------
+
+strokeHeight :: StrokeFont -- ^ Stroke font to use.
+             -> IO GLfloat -- ^ Height in units.
+strokeHeight f = glutStrokeHeight =<< marhshalStrokeFont f

@@ -1,191 +1,191 @@------------------------------------------------------------------------------------ |--- Module      :  Graphics.UI.GLUT.GameMode--- Copyright   :  (c) Sven Panne 2002-2005--- License     :  BSD-style (see the file libraries/GLUT/LICENSE)------ Maintainer  :  sven.panne@aedion.de--- 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+--------------------------------------------------------------------------------
+-- |
+-- 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

@@ -1,773 +1,773 @@------------------------------------------------------------------------------------ |--- Module      :  Graphics.UI.GLUT.Initialization--- Copyright   :  (c) Sven Panne 2002-2005--- License     :  BSD-style (see the file libraries/GLUT/LICENSE)------ Maintainer  :  sven.panne@aedion.de--- 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+--------------------------------------------------------------------------------
+-- |
+-- 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

@@ -1,248 +1,248 @@-{-# OPTIONS_GHC -fno-cse #-}------------------------------------------------------------------------------------- |--- Module      :  Graphics.UI.GLUT.Menu--- Copyright   :  (c) Sven Panne 2002-2005--- License     :  BSD-style (see the file libraries/GLUT/LICENSE)------ Maintainer  :  sven.panne@aedion.de--- 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 ( empty, lookup, insert, delete )-import Control.Monad-import Data.Map ( Map )-import Foreign.C.String-import Foreign.C.Types-import Foreign.Ptr-import Graphics.Rendering.OpenGL ( get, ($=), StateVar-                                 , makeStateVar, GettableStateVar-                                 , makeGettableStateVar )-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.-newtype Menu = Menu [MenuItem]---- | 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@(Menu items) = do-   win <- getCurrentWindow "attachMenu"-   let hook = MenuHook win mouseButton-   detachMenu hook-   unless (null items) $ 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 items) = do-   let callbackArray = listArray (1, length items) (map makeCallback items)-   cb <- makeMenuFunc (\i -> callbackArray ! (fromIntegral i))-   menuID <- glutCreateMenu cb-   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, see 'isRealMenu'.--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+{-# 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 ( empty, lookup, insert, delete )
+import Control.Monad
+import Data.Map ( Map )
+import Foreign.C.String
+import Foreign.C.Types
+import Foreign.Ptr
+import Graphics.Rendering.OpenGL ( get, ($=), StateVar
+                                 , makeStateVar, GettableStateVar
+                                 , makeGettableStateVar )
+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.
+newtype Menu = Menu [MenuItem]
+
+-- | 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@(Menu items) = do
+   win <- getCurrentWindow "attachMenu"
+   let hook = MenuHook win mouseButton
+   detachMenu hook
+   unless (null items) $ 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 items) = do
+   let callbackArray = listArray (1, length items) (map makeCallback items)
+   cb <- makeMenuFunc (\i -> callbackArray ! (fromIntegral i))
+   menuID <- glutCreateMenu cb
+   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