Split the Graphics.GL.Functions implementation into more manageable chunks.

Author: svenpanne

CHANGELOG.md

@@ -1,6 +1,7 @@
 3.2.1.0
 -------
 * Updated OpenGL registry to r33061.
+* Split the `Graphics.GL.Functions` implementation into more manageable chunks.
 
 3.2.0.0
 -------

OpenGLRaw.cabal

@@ -609,6 +609,38 @@ library
   other-modules:
     Graphics.GL.ExtensionPredicates
     Graphics.GL.Foreign
+    Graphics.GL.Functions.F01
+    Graphics.GL.Functions.F02
+    Graphics.GL.Functions.F03
+    Graphics.GL.Functions.F04
+    Graphics.GL.Functions.F05
+    Graphics.GL.Functions.F06
+    Graphics.GL.Functions.F07
+    Graphics.GL.Functions.F08
+    Graphics.GL.Functions.F09
+    Graphics.GL.Functions.F10
+    Graphics.GL.Functions.F11
+    Graphics.GL.Functions.F12
+    Graphics.GL.Functions.F13
+    Graphics.GL.Functions.F14
+    Graphics.GL.Functions.F15
+    Graphics.GL.Functions.F16
+    Graphics.GL.Functions.F17
+    Graphics.GL.Functions.F18
+    Graphics.GL.Functions.F19
+    Graphics.GL.Functions.F20
+    Graphics.GL.Functions.F21
+    Graphics.GL.Functions.F22
+    Graphics.GL.Functions.F23
+    Graphics.GL.Functions.F24
+    Graphics.GL.Functions.F25
+    Graphics.GL.Functions.F26
+    Graphics.GL.Functions.F27
+    Graphics.GL.Functions.F28
+    Graphics.GL.Functions.F29
+    Graphics.GL.Functions.F30
+    Graphics.GL.Functions.F31
+    Graphics.GL.Functions.F32
   c-sources:
     cbits/HsOpenGLRaw.c
   hs-source-dirs: src

RegistryProcessor/src/Main.hs

@@ -159,40 +159,61 @@ printForeign sigMap = do
     SI.hPutStrLn h $ "module " ++ moduleName ++ " where"
     SI.hPutStrLn h ""
     SI.hPutStrLn h "import Foreign.C.Types"
+    SI.hPutStrLn h "import Foreign.Marshal.Error ( throwIf )"
     SI.hPutStrLn h "import Foreign.Ptr"
+    SI.hPutStrLn h $ "import " ++ moduleNameFor ["GetProcAddress"] ++ " ( getProcAddress )"
     SI.hPutStrLn h $ "import " ++ moduleNameFor ["Types"]
     SI.hPutStrLn h "import Numeric.Fixed"
     SI.hPutStrLn h "import Numeric.Half"
     SI.hPutStrLn h ""
+    SI.hPutStrLn h "getCommand :: String -> IO (FunPtr a)"
+    SI.hPutStrLn h "getCommand cmd ="
+    SI.hPutStrLn h "  throwIfNullFunPtr (\"unknown OpenGL command \" ++ cmd) $ getProcAddress cmd"
+    SI.hPutStrLn h "  where throwIfNullFunPtr :: String -> IO (FunPtr a) -> IO (FunPtr a)"
+    SI.hPutStrLn h "        throwIfNullFunPtr = throwIf (== nullFunPtr) . const"
+    SI.hPutStrLn h ""
     mapM_ (SI.hPutStrLn h . uncurry makeImportDynamic) (M.assocs sigMap)
 
+chunksOf :: Int -> [a] -> [[a]]
+chunksOf n = takeWhile (not . null) . L.unfoldr (Just . splitAt n)
+
+justifyRight :: Int -> a -> [a] -> [a]
+justifyRight n c xs = reverse . take (max n (length xs)) . (++ repeat c) . reverse $ xs
+
 printFunctions :: API -> Registry -> M.Map String String -> IO ()
 printFunctions api registry sigMap = do
   let comment =
         ["All raw functions from the",
          "<http://www.opengl.org/registry/ OpenGL registry>."]
+      cmds = chunksOf 100 . M.toAscList . commands $ registry
+      mnames = [ [ "Functions", "F" ++ justifyRight 2 '0' (show i) ] |
+                   i <- [ 1 .. length cmds ] ]
   startModule ["Functions"] Nothing comment $ \moduleName h -> do
     SI.hPutStrLn h $ "module " ++ moduleName ++ " ("
-    SI.hPutStrLn h . separate unCommandName . M.keys . commands $ registry
+    SI.hPutStrLn h . separate (("module " ++) . moduleNameFor) $ mnames
     SI.hPutStrLn h ") where"
     SI.hPutStrLn h ""
-    SI.hPutStrLn h "import Control.Monad.IO.Class ( MonadIO(..) )"
-    SI.hPutStrLn h "import Foreign.Marshal.Error ( throwIf )"
-    SI.hPutStrLn h "import Foreign.Ptr ( Ptr, FunPtr, nullFunPtr )"
-    SI.hPutStrLn h "import System.IO.Unsafe ( unsafePerformIO )"
+    mapM_ (SI.hPutStrLn h . ("import " ++) . moduleNameFor) mnames
+  CM.zipWithM_ (printSubFunctions api registry sigMap) mnames cmds
+
+printSubFunctions :: API -> Registry -> M.Map String String ->
+                     [String] -> [(CommandName, Command)] -> IO ()
+printSubFunctions api registry sigMap mname cmds = do
+  let comment =
+        ["Raw functions from the",
+         "<http://www.opengl.org/registry/ OpenGL registry>."]
+  startModule mname (Just "{-# OPTIONS_HADDOCK hide #-}") comment $ \moduleName h -> do
+    SI.hPutStrLn h $ "module " ++ moduleName ++ " ("
+    SI.hPutStrLn h . separate unCommandName . map fst $ cmds
+    SI.hPutStrLn h ") where"
     SI.hPutStrLn h ""
+    SI.hPutStrLn h "import Control.Monad.IO.Class ( MonadIO(..) )"
+    SI.hPutStrLn h "import Foreign.Ptr"
     SI.hPutStrLn h $ "import " ++ moduleNameFor ["Foreign"]
-    SI.hPutStrLn h $ "import " ++ moduleNameFor ["GetProcAddress"] ++ " ( getProcAddress )"
     SI.hPutStrLn h $ "import " ++ moduleNameFor ["Types"]
+    SI.hPutStrLn h "import System.IO.Unsafe ( unsafePerformIO )"
     SI.hPutStrLn h ""
-    SI.hPutStrLn h "getCommand :: String -> IO (FunPtr a)"
-    SI.hPutStrLn h "getCommand cmd ="
-    SI.hPutStrLn h "  throwIfNullFunPtr (\"unknown OpenGL command \" ++ cmd) $ getProcAddress cmd"
-    SI.hPutStrLn h ""
-    SI.hPutStrLn h "throwIfNullFunPtr :: String -> IO (FunPtr a) -> IO (FunPtr a)"
-    SI.hPutStrLn h "throwIfNullFunPtr = throwIf (== nullFunPtr) . const"
-    SI.hPutStrLn h ""
-    mapM_ (SI.hPutStrLn h . showCommand api registry sigMap) (M.elems (commands registry))
+    mapM_ (SI.hPutStrLn h . showCommand api registry sigMap . snd) cmds
 
 type ExtensionParts = ([TypeName], [Enum'], [Command])
 type ExtensionModule = (ExtensionName, ExtensionName, ExtensionParts)

src/Graphics/GL/Foreign.hs

@@ -17,11 +17,19 @@
 module Graphics.GL.Foreign where
 
 import Foreign.C.Types
+import Foreign.Marshal.Error ( throwIf )
 import Foreign.Ptr
+import Graphics.GL.GetProcAddress ( getProcAddress )
 import Graphics.GL.Types
 import Numeric.Fixed
 import Numeric.Half
 
+getCommand :: String -> IO (FunPtr a)
+getCommand cmd =
+  throwIfNullFunPtr ("unknown OpenGL command " ++ cmd) $ getProcAddress cmd
+  where throwIfNullFunPtr :: String -> IO (FunPtr a) -> IO (FunPtr a)
+        throwIfNullFunPtr = throwIf (== nullFunPtr) . const
+
 foreign import CALLCONV "dynamic" dyn202
   :: FunPtr (GLDEBUGPROC -> Ptr a -> IO ())
   ->         GLDEBUGPROC -> Ptr a -> IO ()