diff --git a/.gitmodules b/.gitmodules index 6341fcd..66dc091 100644 --- a/.gitmodules +++ b/.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 diff --git a/OpenGLRawgen.cabal b/OpenGLRawgen.cabal index f7fab89..ac6c9fc 100644 --- a/OpenGLRawgen.cabal +++ b/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 diff --git a/depsinstall.sh b/depsinstall.sh index d593d7c..95a5424 100755 --- a/depsinstall.sh +++ b/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 diff --git a/haskell-src-exts-qq b/haskell-src-exts-qq new file mode 160000 index 0000000..d1f4b13 --- /dev/null +++ b/haskell-src-exts-qq @@ -0,0 +1 @@ +Subproject commit d1f4b133a498fb4dd874eced618a279904ec7d19 diff --git a/src/Code/ModuleCode.hs b/src/Code/ModuleCode.hs index 79e1c2f..443d5f6 100644 --- a/src/Code/ModuleCode.hs +++ b/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.