Quasi

.gitmodules

@@ -4,6 +4,9 @@
 [submodule "opengl-api"]
 	path = opengl-api
 	url = git://github.com/Laar/opengl-api.git
+[submodule "haskell-src-exts-qq"]
+	path = haskell-src-exts-qq
+	url = git://github.com/Laar/haskell-src-exts-qq.git
 [submodule "OpenGLRawgenBase"]
 	path = OpenGLRawgenBase
 	url = git://github.com/Laar/OpenGLRawgenBase.git

OpenGLRawgen.cabal

@@ -43,6 +43,7 @@ executable OpenGLRawgen
     opengl-api -any,
     parsec -any,
     xml,
+    haskell-src-exts-qq,
     OpenGLRawgenBase,
     OpenGLRawInterface
   ghc-options: -Wall -O2 -rtsopts

depsinstall.sh

@@ -6,5 +6,5 @@ then
 fi
 CABAL="$1"
 git submodule update --init --recursive
-$CABAL install opengl-api/ CodeGenerating/ OpenGLRawgenBase/OpenGLRawgenBase/ OpenGLRawgenBase/OpenGLRawInterface/
+$CABAL install opengl-api/ CodeGenerating/ OpenGLRawgenBase/OpenGLRawgenBase/ OpenGLRawgenBase/OpenGLRawInterface/ haskell-src-exts-qq/
 $CABAL install --only-dependencies

src/Code/ModuleCode.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE QuasiQuotes #-}
 -----------------------------------------------------------------------------
 --
 -- Module      :  Code.ModuleCode
@@ -22,6 +23,7 @@ module Code.ModuleCode (
 import Control.Applicative
 import Data.Maybe
 import Data.Traversable(traverse)
+import Language.Haskell.Exts.QQ
 import Language.Haskell.Exts.Syntax
 
 import Language.OpenGLRaw.Base
@@ -131,12 +133,14 @@ toDecls _                             = pure []
 
 enumTemplate :: RawGenMonad m => Name -> ValueType -> Exp -> m [Decl]
 enumTemplate name vType vExp =
-    pure [ oneTypeSig name vType'
-         , oneLiner name [] vExp]
-    where
+    let name' = unname name
         vType' = case vType of
             EnumValue       -> tyCon' "GLenum"
             BitfieldValue   -> tyCon' "GLbitfield"
+    in pure $ [decs|
+        __name'__ :: ((vType'))
+        __name'__ = $vExp
+        |]
 
 -----------------------------------------------------------------------------
 
@@ -159,45 +163,33 @@ fromFType rty atys = foldr TyFun rType $ zipWith toType vars atys
 -- one for the real invoker used to call the GL-function as it is dynamically
 -- imported.
 funcTemplate :: RawGenMonad m => Name -> Type -> GLName -> Category -> m [Decl]
-funcTemplate name ty glname category = flip fmap askExtensionModule $ \emod ->
+funcTemplate name fType glname category = flip fmap askExtensionModule $ \emod ->
         -- Two extra names, the unname function is needed here to keep the
         -- names every where else for type safety, consider this the safe usage of
         -- an unsafe function.
-        let dynEntry = Ident $ "dyn_" ++ unHSName name
-            ptrEntry = Ident $ "ptr_" ++ unHSName name
-            -- The FFI import decl of the form
-            --
-            -- > foreign import stdcall unsafe "dynamic" dyn_funcName ::
-            -- >   InvokerModulePath.Invoker (FuncType -> IO FuncResultType)
-            fimport = ForImp noSrcLoc callConv PlayRisky "dynamic" dynEntry
-                            (TyApp (TyCon . Qual emod $ Ident "Invoker") ty)
-            -- The used/exported function.
-            --
-            -- > funcName :: FuncType -> IO FuncResultType
-            -- > funcName = dyn_FuncName ptr_FuncName
-            function = [oneTypeSig name ty,
-                        oneLiner name [] (var dynEntry @@ var ptrEntry)
-                       ]
-            -- The function used for the function pointer
-            --
-            -- > {-# NOINLINE ptr_funcName #-}
-            -- > ptr_FuncName :: FuncPtr a
-            -- > ptr_FuncName = unsafePerformIO $
-            -- >    ExtensionEntryModulePath.getExtensionEntry "GL_FUNC_CATEGORY" "funcName"
-            funcPointer = [ InlineSig noSrcLoc False AlwaysActive (UnQual ptrEntry)
-                       , oneTypeSig ptrEntry (TyApp (tyCon' "FunPtr") (tyVar' "a"))
-                       , oneLiner ptrEntry []
-                            ( var' "unsafePerformIO" .$. (Var . Qual emod $ Ident "getExtensionEntry")
-                            @@ (Lit . String $ "GL_" ++ showCategory category)
-                            @@ (Lit . String $ "gl" ++ unGLName glname))
-                       ]
-    in fimport : function ++ funcPointer
-
-
-
--- | The temporary 'CallConv' used.
-callConv :: CallConv
-callConv = StdCall
+        let name' = unHSName name
+            dynEntry = "dyn_" ++ name' -- function ptr invoker
+            ptrEntry = "ptr_" ++ name' -- function ptr to the gl function
+            invoker = TyCon . Qual emod $ Ident "Invoker" -- Qualified type for the Invoker
+            -- getExtensionEntry function
+            getExtensionEntry = Var . Qual emod $ Ident "getExtensionEntry" 
+            -- The name of the function to be imported
+            glFuncName       = Lit . String $ "gl" ++ unGLName glname
+            -- The category name string, for error reporting
+            categoryString   = Lit . String $ "GL_" ++ showCategory category
+    in [decs|
+-- The function pointer invoker (uses a temporary callconvention)
+foreign import stdcall unsafe "dynamic" __dynEntry__ :: ((invoker)) ((fType))
+
+-- The actual function (exported)
+__name'__ :: ((fType))
+__name'__ = __dynEntry__ __ptrEntry__
+
+-- The function pointer
+{-# NOINLINE __ptrEntry__ #-}
+__ptrEntry__ :: FunPtr a
+__ptrEntry__ = unsafePerformIO $ $getExtensionEntry $categoryString $glFuncName
+|]
 
 -- | Replace every occurence of a certain calling convention by the given
 -- string.