diff --git a/Bindings/Utilities.hs b/Bindings/Utilities.hs new file mode 100644 --- /dev/null +++ b/Bindings/Utilities.hs @@ -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] diff --git a/ChangeLog b/ChangeLog new file mode 100644 --- /dev/null +++ b/ChangeLog @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright © <2008–2013>, +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/bindings-DSL.cabal b/bindings-DSL.cabal new file mode 100644 --- /dev/null +++ b/bindings-DSL.cabal @@ -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: + . + + . + 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 +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 diff --git a/bindings.cmacros.h b/bindings.cmacros.h new file mode 100644 --- /dev/null +++ b/bindings.cmacros.h @@ -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__ */ + diff --git a/bindings.dsl.h b/bindings.dsl.h new file mode 100644 --- /dev/null +++ b/bindings.dsl.h @@ -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 +#include +#include + +#ifdef __cplusplus +#include +#else +#include +#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,) \ + hsc_cinline(prefix##_##object,Ptr a -> Ptr ) \ + hsc_cinline(prefix##_IS_##object,Ptr a -> ) \ + +#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 ) \ + hsc_cinline(prefix##_IS_##object##_CLASS,Ptr a -> ) \ + hsc_cinline(prefix##_##object##_GET_CLASS,Ptr a -> Ptr ) \ + +#endif /* __BINDINGS_DSL_H__ */ +