bindings-DSL-1.0.23/0000755000000000000000000000000012606513420012177 5ustar0000000000000000bindings-DSL-1.0.23/bindings-DSL.cabal0000644000000000000000000000274312606513420015406 0ustar0000000000000000cabal-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.23 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.23 bindings-DSL-1.0.23/bindings.cmacros.h0000644000000000000000000002331112606513420015573 0ustar0000000000000000/****** * 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-1.0.23/bindings.dsl.h0000644000000000000000000003153112606513420014731 0ustar0000000000000000/****** * 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)) \ #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"); \ #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"); \ #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, array_size[500], is_union[500], is_fam[500]; uintmax_t 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 = div %" PRIuMAX " $ sizeOf $ (undefined :: ", \ bc_fielddata.array_size[i]); \ bc_typemarkup(bc_fielddata.ftype[i]); \ printf(")\n pokeArray (plusPtr p %" PRIuMAX ") $ take s vf", \ bc_fielddata.offset[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 = div %" PRIuMAX " $ sizeOf $ (undefined :: ", \ bc_fielddata.array_size[i]); \ bc_typemarkup(bc_fielddata.ftype[i]); \ printf(") in peekArray s (plusPtr p %" PRIuMAX ")", \ 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 = div %" PRIuMAX " $ sizeOf $ (undefined :: ", \ bc_fielddata.array_size[i]); \ bc_typemarkup(bc_fielddata.ftype[i]); \ printf(")\n pokeArray (plusPtr p %" PRIuMAX ") (take s v%d)", \ bc_fielddata.offset[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__ */ bindings-DSL-1.0.23/ChangeLog0000644000000000000000000000144712606513420013757 0ustar0000000000000000Changes 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. bindings-DSL-1.0.23/LICENSE0000644000000000000000000000275312606513420013213 0ustar0000000000000000Copyright © <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. bindings-DSL-1.0.23/Setup.hs0000644000000000000000000000005712606513420013635 0ustar0000000000000000import Distribution.Simple main = defaultMain bindings-DSL-1.0.23/Bindings/0000755000000000000000000000000012606513420013734 5ustar0000000000000000bindings-DSL-1.0.23/Bindings/Utilities.hs0000644000000000000000000000232512606513420016245 0ustar0000000000000000module 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]