From d0176abdb1de658d00cfff04e5b6621735a23a96 Mon Sep 17 00:00:00 2001 From: Lars Corbijn Date: Fri, 22 Feb 2013 14:53:16 +0100 Subject: [PATCH 1/7] Adds a submodule to the quasiquoting package. --- .gitmodules | 3 +++ haskell-src-exts-qq | 1 + 2 files changed, 4 insertions(+) create mode 160000 haskell-src-exts-qq diff --git a/.gitmodules b/.gitmodules index e2e8ae5..628317d 100644 --- a/.gitmodules +++ b/.gitmodules @@ -4,3 +4,6 @@ [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 diff --git a/haskell-src-exts-qq b/haskell-src-exts-qq new file mode 160000 index 0000000..3de6788 --- /dev/null +++ b/haskell-src-exts-qq @@ -0,0 +1 @@ +Subproject commit 3de67881f367b8fcc2d68ce6cba1f1431138d19a From 9444cd80ee8334437cd66b088fed271a87978bfc Mon Sep 17 00:00:00 2001 From: Lars Corbijn Date: Sun, 17 Feb 2013 17:16:12 +0100 Subject: [PATCH 2/7] Changes the generator to quasiquoting (WARNING) WARNING: to be able to splice types haskell-src-exts-qq was modified. --- OpenGLRawgen.cabal | 3 +- src/Code/ModuleCode.hs | 63 +++++++++++++++++++----------------------- 2 files changed, 30 insertions(+), 36 deletions(-) diff --git a/OpenGLRawgen.cabal b/OpenGLRawgen.cabal index d45380d..7eb8923 100644 --- a/OpenGLRawgen.cabal +++ b/OpenGLRawgen.cabal @@ -42,7 +42,8 @@ executable OpenGLRawgen mtl -any, opengl-api -any, parsec -any, - xml + xml, + haskell-src-exts-qq ghc-options: -Wall -O2 -rtsopts ghc-shared-options: ghc-prof-options: -Wall -O2 -rtsopts -prof -auto-all -caf-all diff --git a/src/Code/ModuleCode.hs b/src/Code/ModuleCode.hs index e62272d..0ad77e1 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 Text.OpenGL.Spec(Category, showCategory) @@ -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,46 +163,35 @@ 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_" ++ unname name - ptrEntry = Ident $ "ptr_" ++ unname 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) + let name' = unname name + dynEntry = "dyn_" ++ name' -- function ptr invoker + ptrEntry = "ptr_" ++ name' -- function ptr to the gl function + -- The FFI import decl using a temporary call convention + invoker = TyCon . Qual emod $ Ident "Invoker" + fimport = [dec| foreign import stdcall unsafe "dynamic" __dynEntry__ :: ((invoker)) ((fType))|] + -- The used/exported function. - -- - -- > funcName :: FuncType -> IO FuncResultType - -- > funcName = dyn_FuncName ptr_FuncName - function = [oneTypeSig name ty, - oneLiner name [] (var dynEntry @@ var ptrEntry) - ] + function = [decs| + __name'__ :: ((fType)) + __name'__ = __dynEntry__ __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" ++ glname)) - ] + getExtensionEntry = Var . Qual emod $ Ident "getExtensionEntry" + glFuncName = Lit . String $ "gl" ++ glname + categoryString = Lit . String $ "GL_" ++ showCategory category + funcPointer = [decs| + {-# NOINLINE __ptrEntry__ #-} + __ptrEntry__ :: FunPtr a + __ptrEntry__ = unsafePerformIO $ $getExtensionEntry $categoryString $glFuncName + |] in fimport : function ++ funcPointer - --- | The temporary 'CallConv' used. -callConv :: CallConv -callConv = StdCall - -- | Replace every occurence of a certain calling convention by the given -- string. replaceCallConv From b29a149d474ac5bd87c07ac7c8af1028a203c9f0 Mon Sep 17 00:00:00 2001 From: Lars Corbijn Date: Sun, 17 Feb 2013 17:23:32 +0100 Subject: [PATCH 3/7] Restructures the function template. --- src/Code/ModuleCode.hs | 37 +++++++++++++++++-------------------- 1 file changed, 17 insertions(+), 20 deletions(-) diff --git a/src/Code/ModuleCode.hs b/src/Code/ModuleCode.hs index 0ad77e1..baf2ae5 100644 --- a/src/Code/ModuleCode.hs +++ b/src/Code/ModuleCode.hs @@ -170,26 +170,23 @@ funcTemplate name fType glname category = flip fmap askExtensionModule $ \emod - let name' = unname name dynEntry = "dyn_" ++ name' -- function ptr invoker ptrEntry = "ptr_" ++ name' -- function ptr to the gl function - -- The FFI import decl using a temporary call convention - invoker = TyCon . Qual emod $ Ident "Invoker" - fimport = [dec| foreign import stdcall unsafe "dynamic" __dynEntry__ :: ((invoker)) ((fType))|] - - -- The used/exported function. - function = [decs| - __name'__ :: ((fType)) - __name'__ = __dynEntry__ __ptrEntry__ - |] - - -- The function used for the function pointer - getExtensionEntry = Var . Qual emod $ Ident "getExtensionEntry" - glFuncName = Lit . String $ "gl" ++ glname - categoryString = Lit . String $ "GL_" ++ showCategory category - funcPointer = [decs| - {-# NOINLINE __ptrEntry__ #-} - __ptrEntry__ :: FunPtr a - __ptrEntry__ = unsafePerformIO $ $getExtensionEntry $categoryString $glFuncName - |] - in fimport : function ++ funcPointer + invoker = TyCon . Qual emod $ Ident "Invoker" -- Qualified type for the Invoker + getExtensionEntry = Var . Qual emod $ Ident "getExtensionEntry" -- getExtensionEntry function + glFuncName = Lit . String $ "gl" ++ glname -- The name of the function to be imported + categoryString = Lit . String $ "GL_" ++ showCategory category -- The category name string + 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 From fc70126d45e758116abb8405bf628d8cedcd1a21 Mon Sep 17 00:00:00 2001 From: Lars Corbijn Date: Fri, 22 Feb 2013 14:58:51 +0100 Subject: [PATCH 4/7] Rebasing fix for the haskell-src-exts-qq update --- haskell-src-exts-qq | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haskell-src-exts-qq b/haskell-src-exts-qq index 3de6788..d1f4b13 160000 --- a/haskell-src-exts-qq +++ b/haskell-src-exts-qq @@ -1 +1 @@ -Subproject commit 3de67881f367b8fcc2d68ce6cba1f1431138d19a +Subproject commit d1f4b133a498fb4dd874eced618a279904ec7d19 From ee6bcf453995726988ba801739faba195266805c Mon Sep 17 00:00:00 2001 From: Lars Corbijn Date: Fri, 22 Feb 2013 20:18:55 +0100 Subject: [PATCH 5/7] Add the haskell-src-exts-qq to travis.yml --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index ba71558..3186164 100644 --- a/.travis.yml +++ b/.travis.yml @@ -4,7 +4,7 @@ before_install: - sudo apt-get install libghc-cmdargs-dev - sudo apt-get install libghc-src-exts-dev install: - - cabal install opengl-api/ CodeGenerating/ + - cabal install opengl-api/ CodeGenerating/ haskell-src-exts-qq/ - cabal install --only-dependencies --enable-tests script: - cabal configure From a9246efb0dc705f1fa5e0eb4054dbe2075660d97 Mon Sep 17 00:00:00 2001 From: Lars Corbijn Date: Sun, 31 Mar 2013 17:49:00 +0200 Subject: [PATCH 6/7] Cleanup after the merge. --- src/Code/ModuleCode.hs | 43 +----------------------------------------- 1 file changed, 1 insertion(+), 42 deletions(-) diff --git a/src/Code/ModuleCode.hs b/src/Code/ModuleCode.hs index bf73d22..81ba0fa 100644 --- a/src/Code/ModuleCode.hs +++ b/src/Code/ModuleCode.hs @@ -167,9 +167,6 @@ 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. -{- -<<<<<<< HEAD --} let name' = unHSName name dynEntry = "dyn_" ++ name' -- function ptr invoker ptrEntry = "ptr_" ++ name' -- function ptr to the gl function @@ -190,45 +187,7 @@ __name'__ = __dynEntry__ __ptrEntry__ __ptrEntry__ :: FunPtr a __ptrEntry__ = unsafePerformIO $ $getExtensionEntry $categoryString $glFuncName |] -{- -======= - 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 ->>>>>>> develop --} + -- | Replace every occurence of a certain calling convention by the given -- string. replaceCallConv From 08c801846e768af7411e229e0b76cae901d84067 Mon Sep 17 00:00:00 2001 From: Lars Corbijn Date: Sun, 31 Mar 2013 17:51:45 +0200 Subject: [PATCH 7/7] Reformated some documentation. --- src/Code/ModuleCode.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/src/Code/ModuleCode.hs b/src/Code/ModuleCode.hs index 81ba0fa..443d5f6 100644 --- a/src/Code/ModuleCode.hs +++ b/src/Code/ModuleCode.hs @@ -171,9 +171,12 @@ funcTemplate name fType glname category = flip fmap askExtensionModule $ \emod - 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 = Var . Qual emod $ Ident "getExtensionEntry" -- getExtensionEntry function - glFuncName = Lit . String $ "gl" ++ unGLName glname -- The name of the function to be imported - categoryString = Lit . String $ "GL_" ++ showCategory category -- The category name string + -- 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))