bindings-DSL (empty) → 1.0.25
raw patch · 7 files changed
Files
- Bindings/Utilities.hs +39/−0
- ChangeLog +35/−0
- LICENSE +29/−0
- Setup.hs +3/−0
- bindings-DSL.cabal +41/−0
- bindings.cmacros.h +293/−0
- bindings.dsl.h +403/−0
+ Bindings/Utilities.hs view
@@ -0,0 +1,39 @@+module Bindings.Utilities (+ storableCast,+ storableCastArray,+ ) where++import Foreign.C+import Foreign.Marshal+import Foreign.Ptr+import Foreign.Storable++-- |'storableCast' works like 'storableCastArray', except that it+-- takes a single value and returns a single value.++storableCast :: (Storable a, Storable b) => a -> IO b+storableCast a = storableCastArray [a] >>= (return . head)++-- |'storableCastArray' takes a list of values of a first type, stores it+-- at a contiguous memory area (that is first blanked with 0s), and then+-- reads it as if it was a list of a second type, with enough elements to+-- fill at least the same space.+--+-- @+-- ghci+-- :m + Bindings.Sandbox Data.Int+-- storableCastArray (replicate 13 (1::Int8)) :: IO [Int32]+-- ==> [16843009,16843009,16843009,1]+-- @++storableCastArray :: (Storable a, Storable b) => [a] -> IO [b]+storableCastArray [] = return []+storableCastArray a = do+ u <- return undefined+ let (q,r) = divMod (length a * (sizeOf . head) a) (sizeOf u)+ let len = max 1 (if r > 0 then q + 1 else q)+ let blank = replicate (len * sizeOf u) (0::CChar)+ b <- withArray blank $ \ptr -> do+ pokeArray (castPtr ptr) a+ peekArray len (castPtr ptr)+ return $ if True then b else [u]
+ ChangeLog view
@@ -0,0 +1,35 @@+Changes in 1.0.19++* Add a change log.++* Support unsafe calls with experimental #ccall_unsafe.++Changes in 1.0.18 (This version has a bug. Marked as such in Hackage)++* Introduce a silly bug to solve a problem that does not exist.++Changes in 1.0.17++* Add Bindings.Utilities module for general utilities.++* Change repository to git.++* Don't underestimate size of field arrays with dimension >= 2.++* Change #callback to #callback_t.++* Keep source of bindings-* libraries with bindings-DSL.++* Add examples used in tutorial.++Changes in 1.0.16++* Use correct value for Storable alignment instead of copying sizeOf.++Changes in 1.0.15++* New hsc2hs template doesn't include some headers, so include it ourselves.++Changes in 1.0.14++* Add functions to get pointers to fields from pointers to structures.
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright © <2008–2013>, <Maurício C. Antunes>+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++ * Neither the name of the author nor the names of contributors+ may be used to endorse or promote products derived from this+ software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED+TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ bindings-DSL.cabal view
@@ -0,0 +1,41 @@+cabal-version: >= 1.8+name: bindings-DSL+homepage: https://github.com/jwiegley/bindings-dsl/wiki+synopsis:+ FFI domain specific language, on top of hsc2hs.+description: + This is a set of macros to be used when writing Haskell FFI.+ They were designed to be able to fully describe C interfaces,+ so that hsc2hs can extract from them all Haskell code needed to+ mimic such interfaces. All Haskell names used are automatically+ derived from C names, structures are mapped to Haskell instances+ of Storable, and there are also macros you can use with C code+ to help write bindings to inline functions or macro functions.+ Documentation is available at package homepage:+ .+ <https://github.com/jwiegley/bindings-dsl/wiki>+ .+ The extra module Bindings.Utilities will contain tools that may+ be convenient when working with FFI.+version: 1.0.25+license: BSD3+license-file: LICENSE+maintainer: John Wiegley <johnw@newartisans.com>+author: Maurício C. Antunes+stability: Stable API, well tested, portable, used in commercial code.+build-type: Simple+bug-reports: https://github.com/jwiegley/bindings-dsl/issues+category: FFI+extra-source-files: ChangeLog+library+ install-includes: bindings.dsl.h , bindings.cmacros.h+ build-depends: base >= 0 && < 1000+ exposed-modules: Bindings.Utilities+source-repository head+ type: git+ location: git://github.com/jwiegley/bindings-dsl+ branch: master+source-repository this+ type: git+ location: git://github.com/jwiegley/bindings-dsl+ tag: 1.0.25
+ bindings.cmacros.h view
@@ -0,0 +1,293 @@+/******+ * Copyright © 2008–2009 Maurício C. Antunes+ * This file is distributed under the BSD license.+ * Check LICENSE file in distribution package for+ * details.+******/++#ifndef __BINDINGS_CMACROS_H__+#define __BINDINGS_CMACROS_H__++#define BC_GLOBALARRAY(name,type) \+type const *array_##name (void) \+{ \+ return name; \+} \++#define BC_INLINE_(name,ret) \+ret inline_##name (void) \+{ \+ return name; \+} \++#define BC_INLINE_VOID(name) \+void inline_##name (void) \+{ \+ name; \+} \++#define BC_INLINE0(name,ret) \+ret inline_##name (void) \+{ \+ return name (); \+} \++#define BC_INLINE0VOID(name) \+void inline_##name (void) \+{ \+ name (); \+} \++#define BC_INLINE1(name,t1,ret) \+ret inline_##name (t1 v1) \+{ \+ return name (v1); \+} \++#define BC_INLINE1VOID(name,t1) \+void inline_##name (t1 v1) \+{ \+ name (v1); \+} \++#define BC_INLINE2(name,t1,t2,ret) \+ret inline_##name (t1 v1,t2 v2) \+{ \+ return name (v1,v2); \+} \++#define BC_INLINE2VOID(name,t1,t2) \+void inline_##name (t1 v1,t2 v2) \+{ \+ name (v1,v2); \+} \++#define BC_INLINE3(name,t1,t2,t3,ret) \+ret inline_##name (t1 v1,t2 v2,t3 v3) \+{ \+ return name (v1,v2,v3); \+} \++#define BC_INLINE3VOID(name,t1,t2,t3) \+void inline_##name (t1 v1,t2 v2,t3 v3) \+{ \+ name (v1,v2,v3); \+} \++#define BC_INLINE4(name,t1,t2,t3,t4,ret) \+ret inline_##name (t1 v1,t2 v2,t3 v3,t4 v4) \+{ \+ return name (v1,v2,v3,v4); \+} \++#define BC_INLINE4VOID(name,t1,t2,t3,t4) \+void inline_##name (t1 v1,t2 v2,t3 v3,t4 v4) \+{ \+ name (v1,v2,v3,v4); \+} \++#define BC_INLINE5(name,t1,t2,t3,t4,t5,ret) \+ret inline_##name (t1 v1,t2 v2,t3 v3,t4 v4,t5 v5) \+{ \+ return name (v1,v2,v3,v4,v5); \+} \++#define BC_INLINE5VOID(name,t1,t2,t3,t4,t5) \+void inline_##name (t1 v1,t2 v2,t3 v3,t4 v4,t5 v5) \+{ \+ name (v1,v2,v3,v4,v5); \+} \++#define BC_INLINE6(name,t1,t2,t3,t4,t5,t6,ret) \+ret inline_##name (t1 v1,t2 v2,t3 v3,t4 v4,t5 v5,t6 v6) \+{ \+ return name (v1,v2,v3,v4,v5,v6); \+} \++#define BC_INLINE6VOID(name,t1,t2,t3,t4,t5,t6) \+void inline_##name (t1 v1,t2 v2,t3 v3,t4 v4,t5 v5,t6 v6) \+{ \+ name (v1,v2,v3,v4,v5,v6); \+} \++#define BC_INLINE7(name,t1,t2,t3,t4,t5,t6,t7,ret) \+ret inline_##name (t1 v1,t2 v2,t3 v3,t4 v4,t5 v5,t6 v6,t7 v7) \+{ \+ return name (v1,v2,v3,v4,v5,v6,v7); \+} \++#define BC_INLINE7VOID(name,t1,t2,t3,t4,t5,t6,t7) \+void inline_##name (t1 v1,t2 v2,t3 v3,t4 v4,t5 v5,t6 v6,t7 v7) \+{ \+ name (v1,v2,v3,v4,v5,v6,v7); \+} \++#define BC_INLINE8(name,t1,t2,t3,t4,t5,t6,t7,t8,ret) \+ret inline_##name (t1 v1,t2 v2,t3 v3,t4 v4,t5 v5,t6 v6,t7 v7,t8 v8) \+{ \+ return name (v1,v2,v3,v4,v5,v6,v7,v8); \+} \++#define BC_INLINE8VOID(name,t1,t2,t3,t4,t5,t6,t7,t8) \+void inline_##name (t1 v1,t2 v2,t3 v3,t4 v4,t5 v5,t6 v6,t7 v7,t8 v8) \+{ \+ name (v1,v2,v3,v4,v5,v6,v7,v8); \+} \++#define BC_INLINE9(name,t1,t2,t3,t4,t5,t6,t7,t8,t9,ret) \+ret inline_##name (t1 v1,t2 v2,t3 v3,t4 v4,t5 v5,t6 v6,t7 v7,t8 v8,t9 v9) \+{ \+ return name (v1,v2,v3,v4,v5,v6,v7,v8,v9); \+} \++#define BC_INLINE9VOID(name,t1,t2,t3,t4,t5,t6,t7,t8,t9) \+void inline_##name (t1 v1,t2 v2,t3 v3,t4 v4,t5 v5,t6 v6,t7 v7,t8 v8,t9 v9) \+{ \+ name (v1,v2,v3,v4,v5,v6,v7,v8,v9); \+} \++#define BC_INLINE10(name,t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,ret) \+ret inline_##name (t1 v1,t2 v2,t3 v3,t4 v4,t5 v5,t6 v6,t7 v7,t8 v8,t9 v9,t10 v10) \+{ \+ return name (v1,v2,v3,v4,v5,v6,v7,v8,v9,v10); \+} \++#define BC_INLINE10VOID(name,t1,t2,t3,t4,t5,t6,t7,t8,t9,t10) \+void inline_##name (t1 v1,t2 v2,t3 v3,t4 v4,t5 v5,t6 v6,t7 v7,t8 v8,t9 v9,t10 v10) \+{ \+ name (v1,v2,v3,v4,v5,v6,v7,v8,v9,v10); \+} \++#define BC_INLINE11(name,t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,ret) \+ret inline_##name (t1 v1,t2 v2,t3 v3,t4 v4,t5 v5,t6 v6,t7 v7,t8 v8,t9 v9,t10 v10,t11 v11) \+{ \+ return name (v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11); \+} \++#define BC_INLINE11VOID(name,t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11) \+void inline_##name (t1 v1,t2 v2,t3 v3,t4 v4,t5 v5,t6 v6,t7 v7,t8 v8,t9 v9,t10 v10,t11 v11) \+{ \+ name (v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11); \+} \++#define BC_INLINE12(name,t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,t12,ret) \+ret inline_##name (t1 v1,t2 v2,t3 v3,t4 v4,t5 v5,t6 v6,t7 v7,t8 v8,t9 v9,t10 v10,t11 v11,t12 v12) \+{ \+ return name (v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12); \+} \++#define BC_INLINE12VOID(name,t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,t12) \+void inline_##name (t1 v1,t2 v2,t3 v3,t4 v4,t5 v5,t6 v6,t7 v7,t8 v8,t9 v9,t10 v10,t11 v11,t12 v12) \+{ \+ name (v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12); \+} \++#define BC_INLINE13(name,t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,t12,t13,ret) \+ret inline_##name (t1 v1,t2 v2,t3 v3,t4 v4,t5 v5,t6 v6,t7 v7,t8 v8,t9 v9,t10 v10,t11 v11,t12 v12,t13 v13) \+{ \+ return name (v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13); \+} \++#define BC_INLINE13VOID(name,t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,t12,t13) \+void inline_##name (t1 v1,t2 v2,t3 v3,t4 v4,t5 v5,t6 v6,t7 v7,t8 v8,t9 v9,t10 v10,t11 v11,t12 v12,t13 v13) \+{ \+ name (v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13); \+} \++#define BC_INLINE14(name,t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,t12,t13,t14,ret) \+ret inline_##name (t1 v1,t2 v2,t3 v3,t4 v4,t5 v5,t6 v6,t7 v7,t8 v8,t9 v9,t10 v10,t11 v11,t12 v12,t13 v13,t14 v14) \+{ \+ return name (v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14); \+} \++#define BC_INLINE14VOID(name,t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,t12,t13,t14) \+void inline_##name (t1 v1,t2 v2,t3 v3,t4 v4,t5 v5,t6 v6,t7 v7,t8 v8,t9 v9,t10 v10,t11 v11,t12 v12,t13 v13,t14 v14) \+{ \+ name (v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14); \+} \++#define BC_INLINE15(name,t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,t12,t13,t14,t15,ret) \+ret inline_##name (t1 v1,t2 v2,t3 v3,t4 v4,t5 v5,t6 v6,t7 v7,t8 v8,t9 v9,t10 v10,t11 v11,t12 v12,t13 v13,t14 v14,t15 v15) \+{ \+ return name (v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15); \+} \++#define BC_INLINE15VOID(name,t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,t12,t13,t14,t15) \+void inline_##name (t1 v1,t2 v2,t3 v3,t4 v4,t5 v5,t6 v6,t7 v7,t8 v8,t9 v9,t10 v10,t11 v11,t12 v12,t13 v13,t14 v14,t15 v15) \+{ \+ name (v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15); \+} \++#define BC_INLINE16(name,t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,t12,t13,t14,t15,t16,ret) \+ret inline_##name (t1 v1,t2 v2,t3 v3,t4 v4,t5 v5,t6 v6,t7 v7,t8 v8,t9 v9,t10 v10,t11 v11,t12 v12,t13 v13,t14 v14,t15 v15,t16 v16) \+{ \+ return name (v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15,v16); \+} \++#define BC_INLINE16VOID(name,t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,t12,t13,t14,t15,t16) \+void inline_##name (t1 v1,t2 v2,t3 v3,t4 v4,t5 v5,t6 v6,t7 v7,t8 v8,t9 v9,t10 v10,t11 v11,t12 v12,t13 v13,t14 v14,t15 v15,t16 v16) \+{ \+ name (v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15,v16); \+} \++#define BC_INLINE17(name,t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,t12,t13,t14,t15,t16,t17,ret) \+ret inline_##name (t1 v1,t2 v2,t3 v3,t4 v4,t5 v5,t6 v6,t7 v7,t8 v8,t9 v9,t10 v10,t11 v11,t12 v12,t13 v13,t14 v14,t15 v15,t16 v16,t17 v17) \+{ \+ return name (v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15,v16,v17); \+} \++#define BC_INLINE17VOID(name,t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,t12,t13,t14,t15,t16,t17) \+void inline_##name (t1 v1,t2 v2,t3 v3,t4 v4,t5 v5,t6 v6,t7 v7,t8 v8,t9 v9,t10 v10,t11 v11,t12 v12,t13 v13,t14 v14,t15 v15,t16 v16,t17 v17) \+{ \+ name (v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15,v16,v17); \+} \++#define BC_INLINE18(name,t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,t12,t13,t14,t15,t16,t17,t18,ret) \+ret inline_##name (t1 v1,t2 v2,t3 v3,t4 v4,t5 v5,t6 v6,t7 v7,t8 v8,t9 v9,t10 v10,t11 v11,t12 v12,t13 v13,t14 v14,t15 v15,t16 v16,t17 v17,t18 v18) \+{ \+ return name (v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15,v16,v17,v18); \+} \++#define BC_INLINE18VOID(name,t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,t12,t13,t14,t15,t16,t17,t18) \+void inline_##name (t1 v1,t2 v2,t3 v3,t4 v4,t5 v5,t6 v6,t7 v7,t8 v8,t9 v9,t10 v10,t11 v11,t12 v12,t13 v13,t14 v14,t15 v15,t16 v16,t17 v17,t18 v18) \+{ \+ name (v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15,v16,v17,v18); \+} \++#define BC_INLINE19(name,t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,t12,t13,t14,t15,t16,t17,t18,t19,ret) \+ret inline_##name (t1 v1,t2 v2,t3 v3,t4 v4,t5 v5,t6 v6,t7 v7,t8 v8,t9 v9,t10 v10,t11 v11,t12 v12,t13 v13,t14 v14,t15 v15,t16 v16,t17 v17,t18 v18,t19 v19) \+{ \+ return name (v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15,v16,v17,v18,v19); \+} \++#define BC_INLINE19VOID(name,t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,t12,t13,t14,t15,t16,t17,t18,t19) \+void inline_##name (t1 v1,t2 v2,t3 v3,t4 v4,t5 v5,t6 v6,t7 v7,t8 v8,t9 v9,t10 v10,t11 v11,t12 v12,t13 v13,t14 v14,t15 v15,t16 v16,t17 v17,t18 v18,t19 v19) \+{ \+ name (v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15,v16,v17,v18,v19); \+} \++#define BC_INLINE20(name,t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,t12,t13,t14,t15,t16,t17,t18,t19,t20,ret) \+ret inline_##name (t1 v1,t2 v2,t3 v3,t4 v4,t5 v5,t6 v6,t7 v7,t8 v8,t9 v9,t10 v10,t11 v11,t12 v12,t13 v13,t14 v14,t15 v15,t16 v16,t17 v17,t18 v18,t19 v19,t20 v20) \+{ \+ return name (v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15,v16,v17,v18,v19,v20); \+} \++#define BC_INLINE20VOID(name,t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,t12,t13,t14,t15,t16,t17,t18,t19,t20) \+void inline_##name (t1 v1,t2 v2,t3 v3,t4 v4,t5 v5,t6 v6,t7 v7,t8 v8,t9 v9,t10 v10,t11 v11,t12 v12,t13 v13,t14 v14,t15 v15,t16 v16,t17 v17,t18 v18,t19 v19,t20 v20) \+{ \+ name (v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15,v16,v17,v18,v19,v20); \+} \++#define BC_GOBJECT_NOTCLASSED(prefix,object,CamelCase) \+ BC_INLINE_(prefix##_TYPE_##object,GType) \+ BC_INLINE1(prefix##_##object,void*,CamelCase*) \+ BC_INLINE1(prefix##_IS_##object,void*,gboolean) \++#define BC_GOBJECT(prefix,object,CamelCase) \+ BC_GOBJECT_NOTCLASSED(prefix,object,CamelCase) \+ BC_INLINE1(prefix##_##object##_CLASS,void*,CamelCase##Class*) \+ BC_INLINE1(prefix##_IS_##object##_CLASS,void*,gboolean) \+ BC_INLINE1(prefix##_##object##_GET_CLASS,void*,CamelCase##Class*) \++#endif /* __BINDINGS_CMACROS_H__ */+
+ bindings.dsl.h view
@@ -0,0 +1,403 @@+/******+ * Copyright © 2008–2011 Maurício C. Antunes+ * This file is distributed under the BSD license.+ * Check LICENSE file in distribution package for+ * details.+******/++#ifndef __BINDINGS_DSL_H__+#define __BINDINGS_DSL_H__++#include <stdio.h>+#include <string.h>+#include <ctype.h>++#ifdef __cplusplus+#include <cinttypes>+#else+#include <inttypes.h>+#endif++#define hsc_strict_import(dummy) printf( \+ "import Foreign.Ptr (Ptr,FunPtr,plusPtr)\n" \+ "import Foreign.Ptr (wordPtrToPtr,castPtrToFunPtr)\n" \+ "import Foreign.Storable\n" \+ "import Foreign.C.Types\n" \+ "import Foreign.C.String (CString,CStringLen,CWString,CWStringLen)\n" \+ "import Foreign.Marshal.Alloc (alloca)\n" \+ "import Foreign.Marshal.Array (peekArray,pokeArray)\n" \+ "import Data.Int\n" \+ "import Data.Word\n" \+ ); \++#define bc_word(name) \+ { \+ char *p, *q, buffer_w[strlen(name)+1]; \+ strcpy(buffer_w,name); \+ for (p=strtok(buffer_w," \t");(q=strtok(NULL," \t"));p=q); \+ printf("%s",p); \+ } \++#define bc_glue(type,field) \+ { \+ bc_word(type); \+ printf("'"); \+ char *p, buffer_g[strlen(field)+1]; \+ strcpy(buffer_g,field); \+ for (p=buffer_g;*p;p++) \+ *p = *p=='.' ? '\'' : ispunct(*p) ? '_' : *p; \+ bc_word(buffer_g); \+ } \++#define bc_typemarkup(name) \+ { \+ char buffer_t[strlen(name)+1]; \+ strcpy(buffer_t,name); \+ char *p1,*p2,*p3; \+ p1 = buffer_t; \+ while (*p1) \+ { \+ for (p2=p1;*p2 && *p2!='<';p2++); \+ for (p3=p2;*p3 && *p3!='>';p3++); \+ if (*p2 == '<') *p2++ = '\0'; \+ if (*p3 == '>') *p3++ = '\0'; \+ printf("%s",p1); \+ if (*p2) bc_conid(p2); \+ p1 = p3; \+ } \+ } \++#define bc_varid(name) {printf("c'");bc_word(name);}; \++#define bc_conid(name) {printf("C'");bc_word(name);}; \++#define bc_ptrid(name) {printf("p'");bc_word(name);}; \++#define bc_wrapper(name) {printf("mk'");bc_word(name);}; \++#define bc_dynamic(name) {printf("mK'");bc_word(name);}; \++#define bc_decimal(name) (name) > 0 \+ ? printf("%" PRIuMAX,(uintmax_t)(name)) \+ : printf("%" PRIdMAX,(intmax_t)(name)) \++#define bc_wordptr(name) printf("%" PRIuPTR,(uintptr_t)(name)) \++#define bc_float(name) printf("%Le",(long double)(name)) \++#if __GLASGOW_HASKELL__ >= 800+/* GHC has supported pattern synonym type signatures since 7.10, but due to a+ * bug in 7.10, GHC will reject the type signature we try to give to our+ * pattern synonyms, even though they are valid. As a result, we only produce+ * explicit type signatures on GHC 8.0 or later, where the feature works+ * as intended.+ */+# define bc_patsig(name,constr) \+ printf("pattern ");bc_conid(name); \+ printf(" :: (Eq a, %s a) => a",constr);+#else+# define bc_patsig(name,constr)+#endif++#define hsc_num(name) \+ bc_varid(# name);printf(" = ");bc_decimal(name);printf("\n"); \+ bc_varid(# name);printf(" :: (Num a) => a\n"); \++#define hsc_fractional(name) \+ bc_varid(# name);printf(" = ");bc_float(name);printf("\n"); \+ bc_varid(# name);printf(" :: (Fractional a) => a\n"); \++#if __GLASGOW_HASKELL__ >= 710+# define hsc_num_pattern(name) \+ printf("pattern ");bc_conid(# name);printf(" <- ((== ("); \+ bc_decimal(name);printf(")) -> True) where\n "); \+ bc_conid(# name);printf(" = ");bc_decimal(name);printf("\n"); \+ bc_patsig(# name,"Num");++# define hsc_fractional_pattern(name) \+ printf("pattern ");bc_conid(# name);printf(" <- ((== ("); \+ bc_float(name);printf(")) -> True) where\n "); \+ bc_conid(# name);printf(" = ");bc_float(name);printf("\n"); \+ bc_patsig(# name,"Fractional");+#endif++#define hsc_pointer(name) \+ bc_varid(# name);printf(" = wordPtrToPtr "); \+ bc_wordptr(name);printf("\n"); \+ bc_varid(# name);printf(" :: Ptr a\n"); \++#define hsc_function_pointer(name) \+ bc_varid(# name);printf(" = (castPtrToFunPtr . wordPtrToPtr) "); \+ bc_wordptr(name);printf("\n"); \+ bc_varid(# name);printf(" :: FunPtr a\n"); \++#ifdef BINDINGS_STDCALLCONV+#define hsc_ccall(name,type) hsc_callconv(name,stdcall,type)+#else+#define hsc_ccall(name,type) hsc_callconv(name,ccall,type)+#endif++#define hsc_callconv(name,conv,type) \+ printf("foreign import "# conv" \"%s\" ",# name); \+ bc_varid(# name);printf("\n"); \+ printf(" :: ");bc_typemarkup(# type);printf("\n"); \+ printf("foreign import "# conv" \"&%s\" ",# name); \+ bc_ptrid(# name);printf("\n"); \+ printf(" :: FunPtr (");bc_typemarkup(# type);printf(")\n"); \++/* experimental support for unsafe calls */+#define hsc_ccall_unsafe(name,type) \+ printf("foreign import ccall unsafe \"%s\" unsafe'",# name); \+ bc_varid(# name);printf("\n"); \+ printf(" :: ");bc_typemarkup(# type);printf("\n"); \+ printf("foreign import ccall unsafe \"&%s\" unsafe'",# name); \+ bc_ptrid(# name);printf("\n"); \+ printf(" :: FunPtr (");bc_typemarkup(# type);printf(")\n"); \++/* experimental support for interruptible calls */+#define hsc_ccall_interruptible(name,type) \+ printf("foreign import ccall interruptible \"%s\" interruptible'",# name); \+ bc_varid(# name);printf("\n"); \+ printf(" :: ");bc_typemarkup(# type);printf("\n"); \+ printf("foreign import ccall interruptible \"&%s\" interruptible'",# name); \+ bc_ptrid(# name);printf("\n"); \+ printf(" :: FunPtr (");bc_typemarkup(# type);printf(")\n"); \++#define hsc_cinline(name,type) \+ printf("foreign import ccall \"inline_%s\" ",# name); \+ bc_varid(# name);printf("\n"); \+ printf(" :: ");bc_typemarkup(# type);printf("\n"); \++#define hsc_globalvar(name,type) \+ printf("foreign import ccall \"&%s\" ",# name); \+ bc_ptrid(# name);printf("\n"); \+ printf(" :: Ptr (");bc_typemarkup(# type);printf(")\n"); \++#define hsc_globalarray(name,type) \+ printf("foreign import ccall \"array_%s\" ",# name); \+ bc_varid(# name);printf("\n"); \+ printf(" :: Ptr (");bc_typemarkup(# type);printf(")\n"); \++#define hsc_integral_t(name) \+ printf("type ");bc_conid(# name);printf(" = "); \+ { \+ int sign = (name)(-1)<0; \+ size_t size = sizeof(name); \+ if (size==sizeof(int)) printf("%s",sign?"CInt":"CUInt"); \+ else if (size==sizeof(char)) printf("%s", \+ (char)(-1)<0?(sign?"CChar":"CUChar"):(sign?"CSChar":"CChar")); \+ else printf("%s%" PRIuMAX,sign?"Int":"Word",(uintmax_t)(8*size)); \+ printf("\n"); \+ } \++#define hsc_opaque_t(name) \+ printf("data ");bc_conid(# name); \+ printf(" = "); \+ bc_conid(# name);printf("\n"); \++#define hsc_synonym_t(name,type) \+ printf("type ");bc_conid(# name); \+ printf(" = "); \+ bc_typemarkup(# type); \+ printf("\n"); \++#ifdef BINDINGS_STDCALLCONV+#define hsc_callback(name,type) hsc_callbackconv(name,stdcall,type)+#define hsc_callback_t(name,type) hsc_callbackconv(name,stdcall,type)+#else+#define hsc_callback(name,type) hsc_callbackconv(name,ccall,type)+#define hsc_callback_t(name,type) hsc_callbackconv(name,ccall,type)+#endif++#define hsc_callbackconv(name,conv,type) \+ printf("type ");bc_conid(# name);printf(" = FunPtr ("); \+ bc_typemarkup(# type);printf(")\n"); \+ printf("foreign import "# conv" \"wrapper\" "); \+ bc_wrapper(# name);printf("\n"); \+ printf(" :: (");bc_typemarkup(# type); \+ printf(") -> IO ");bc_conid(# name);printf("\n"); \+ printf("foreign import "# conv" \"dynamic\" "); \+ bc_dynamic(# name);printf("\n"); \+ printf(" :: ");bc_conid(# name); \+ printf(" -> (");bc_typemarkup(# type);printf(")\n"); \++static struct {+ int n, is_union[500], is_fam[500];+ uintmax_t array_size[500], offset[500];+ char fname[500][1000], ftype[500][1000];+} bc_fielddata;++#define bc_fieldname(type,field) {printf("c'");bc_glue(type,field);}; \++#define bc_unionupdate(type,field) {printf("u'");bc_glue(type,field);}; \++#define bc_fieldoffset(type,field) {printf("p'");bc_glue(type,field);}; \++#define hsc_starttype(name) \+ { \+ struct {char _; name v;} bc_refdata; \+ size_t typesize = sizeof bc_refdata.v; \+ ptrdiff_t typealign = (char*)&bc_refdata.v - (char*)&bc_refdata; \+ bc_fielddata.n = 0; \+ char typename[] = # name; \+ int index; \+ int standalone_deriving = 0; \++#define bc_basicfield(name,type,u,f) \+ index = bc_fielddata.n++; \+ bc_fielddata.offset[index] = (uintmax_t) \+ ((char*)&bc_refdata.v.name - (char*)&bc_refdata.v); \+ bc_fielddata.array_size[index] = 0; \+ bc_fielddata.is_union[index] = u; \+ bc_fielddata.is_fam[index] = f; \+ strcpy(bc_fielddata.fname[index],# name); \+ strcpy(bc_fielddata.ftype[index],type); \++#define hsc_field(name,type) \+ bc_basicfield(name,# type,0,0); \++#define hsc_union_field(name,type) \+ bc_basicfield(name,# type,1,0); \++#define hsc_flexible_array_member(name,type) \+ bc_basicfield(name,# type,0,1); \++#define hsc_array_field(name,type) \+ bc_basicfield(name,# type,0,0); \+ bc_fielddata.array_size[index] = sizeof bc_refdata.v.name \++#define hsc_union_array_field(name,type) \+ bc_basicfield(name,# type,1,0); \+ bc_fielddata.array_size[index] = sizeof bc_refdata.v.name \++#define hsc_stoptype(dummy) \+ printf("data ");bc_conid(typename);printf(" = "); \+ bc_conid(typename);printf("{\n"); \+ int i; \+ for (i=0; i < bc_fielddata.n; i++) \+ { \+ printf(" "); \+ bc_fieldname(typename,bc_fielddata.fname[i]); \+ printf(" :: "); \+ if (bc_fielddata.array_size[i] > 0 || bc_fielddata.is_fam[i]) \+ printf("["); \+ bc_typemarkup(bc_fielddata.ftype[i]); \+ if (bc_fielddata.array_size[i] > 0 || bc_fielddata.is_fam[i]) \+ printf("]"); \+ if (i+1 < bc_fielddata.n) printf(","); \+ printf("\n"); \+ } \+ if (!standalone_deriving) \+ printf("} deriving (Eq,Show)\n"); \+ else \+ { \+ printf("}\n"); \+ printf("deriving instance Eq ");bc_conid(typename);printf("\n"); \+ printf("deriving instance Show ");bc_conid(typename);printf("\n"); \+ } \+ for (i=0; i < bc_fielddata.n; i++) \+ { \+ bc_fieldoffset(typename,bc_fielddata.fname[i]); \+ printf(" p = plusPtr p %" PRIuMAX "\n",bc_fielddata.offset[i]); \+ bc_fieldoffset(typename,bc_fielddata.fname[i]); \+ printf(" :: Ptr (");bc_conid(typename);printf(") -> "); \+ printf("Ptr (");bc_typemarkup(bc_fielddata.ftype[i]);printf(")\n"); \+ } \+ for (i=0; i < bc_fielddata.n; i++) if (bc_fielddata.is_union[i]) \+ { \+ bc_unionupdate(typename,bc_fielddata.fname[i]); \+ printf(" :: ");bc_conid(typename);printf(" -> "); \+ if (bc_fielddata.array_size[i] > 0) printf("["); \+ bc_typemarkup(bc_fielddata.ftype[i]); \+ if (bc_fielddata.array_size[i] > 0) printf("]"); \+ printf(" -> IO ");bc_conid(typename); \+ printf("\n"); \+ bc_unionupdate(typename,bc_fielddata.fname[i]); \+ printf(" v vf = alloca $ \\p -> do\n"); \+ printf(" poke p v\n"); \+ if (bc_fielddata.array_size[i] > 0) \+ { \+ printf(" let s%d = div %" PRIuMAX " $ sizeOf $ (undefined :: ", \+ i, bc_fielddata.array_size[i]); \+ bc_typemarkup(bc_fielddata.ftype[i]); \+ printf(")\n pokeArray (plusPtr p %" PRIuMAX ") $ take s%d vf", \+ bc_fielddata.offset[i], i); \+ } \+ else \+ printf(" pokeByteOff p %" PRIuMAX " vf", \+ bc_fielddata.offset[i]); \+ printf("\n"); \+ printf(" vu <- peek p\n"); \+ printf(" return $ v\n"); \+ int j; \+ for (j=0; j < bc_fielddata.n; j++) if (bc_fielddata.is_union[j]) \+ { \+ printf(" {"); bc_fieldname(typename,bc_fielddata.fname[j]); \+ printf(" = "); bc_fieldname(typename,bc_fielddata.fname[j]); \+ printf(" vu}\n"); \+ } \+ } \+ printf("instance Storable "); \+ bc_conid(typename);printf(" where\n"); \+ printf(" sizeOf _ = %" PRIuMAX "\n alignment _ = %" PRIuMAX "\n", \+ (uintmax_t)(typesize),(uintmax_t)(typealign)); \+ printf(" peek _p = do\n"); \+ for (i=0; i < bc_fielddata.n; i++) \+ { \+ printf(" v%d <- ",i); \+ if (bc_fielddata.is_fam[i]) \+ printf("return []"); \+ else if (bc_fielddata.array_size[i] > 0) \+ { \+ printf ("let s%d = div %" PRIuMAX " $ sizeOf $ (undefined :: ", \+ i, bc_fielddata.array_size[i]); \+ bc_typemarkup(bc_fielddata.ftype[i]); \+ printf(") in peekArray s%d (plusPtr _p %" PRIuMAX ")", \+ i, bc_fielddata.offset[i]); \+ } \+ else \+ printf("peekByteOff _p %" PRIuMAX "", bc_fielddata.offset[i]); \+ printf("\n"); \+ } \+ printf(" return $ ");bc_conid(typename); \+ for (i=0; i < bc_fielddata.n; i++) printf(" v%d",i); \+ printf("\n"); \+ printf(" poke _p (");bc_conid(typename); \+ for (i=0; i < bc_fielddata.n; i++) printf(" v%d",i); \+ printf(") = do\n"); \+ for (i=0; i < bc_fielddata.n; i++) \+ { \+ if (bc_fielddata.is_fam[i]) \+ printf(" pokeArray (plusPtr _p %" PRIuMAX ") v%d", \+ bc_fielddata.offset[i],i); \+ else if (bc_fielddata.array_size[i] > 0) \+ { \+ printf(" let s%d = div %" PRIuMAX " $ sizeOf $ (undefined :: ", \+ i, bc_fielddata.array_size[i]); \+ bc_typemarkup(bc_fielddata.ftype[i]); \+ printf(")\n pokeArray (plusPtr _p %" PRIuMAX ") (take s%d v%d)", \+ bc_fielddata.offset[i], i, i); \+ } \+ else \+ printf(" pokeByteOff _p %" PRIuMAX " v%d", \+ bc_fielddata.offset[i],i); \+ printf("\n"); \+ } \+ printf(" return ()\n"); \+ } \++#define hsc_gobject_notclassed(prefix,object,CamelCase) \+ hsc_opaque_t(CamelCase) \+ hsc_cinline(prefix##_TYPE_##object,<GType>) \+ hsc_cinline(prefix##_##object,Ptr a -> Ptr <CamelCase>) \+ hsc_cinline(prefix##_IS_##object,Ptr a -> <gboolean>) \++#define hsc_gobject(prefix,object,CamelCase) \+ hsc_opaque_t(CamelCase##Class) \+ hsc_gobject_notclassed(prefix,object,CamelCase) \+ hsc_cinline(prefix##_##object##_CLASS,Ptr a -> Ptr <CamelCase##Class>) \+ hsc_cinline(prefix##_IS_##object##_CLASS,Ptr a -> <gboolean>) \+ hsc_cinline(prefix##_##object##_GET_CLASS,Ptr a -> Ptr <CamelCase##Class>) \++#endif /* __BINDINGS_DSL_H__ */+