diff --git a/.hg_archival.txt b/.hg_archival.txt --- a/.hg_archival.txt +++ b/.hg_archival.txt @@ -1,2 +1,2 @@ repo: db8906263ec6e2f02cd51ed9b583ad96027042e9 -node: a03ecc91aa79505a1ba9516d1f713d9c37227a74 +node: c2c4a362ae898822a6fcbc3096e88a6586d87d2e diff --git a/bindings-common.cabal b/bindings-common.cabal --- a/bindings-common.cabal +++ b/bindings-common.cabal @@ -4,12 +4,9 @@ synopsis: Low-level library bindings, base package. description: - The @bindings-*@ set of packages contains low level bindings - for established libraries, and is aimed at developers of higher - level modules that can use it as foundation. They all mimic the - names and functionality of the original libraries. For - a specific library, look for package @bindings-library_name@. -version: 0.2.1 + Facilities to wrap foreign C libraries. Used as basis in + @bindings-*@ packages. +version: 0.2.2 license: BSD3 license-file: LICENSE maintainer: Maurício C. Antunes diff --git a/example/Setup.hs b/example/Setup.hs new file mode 100644 --- /dev/null +++ b/example/Setup.hs @@ -0,0 +1,6 @@ +#!/usr/bin/env runhaskell + +module Main (main) where +import Distribution.Simple + +main = defaultMain diff --git a/example/example.c b/example/example.c new file mode 100644 --- /dev/null +++ b/example/example.c @@ -0,0 +1,93 @@ +#include "example.h" +#include + +void translate (int what, struct unicode_translator *p) +{ + int i; + uint32_t uni; + + switch (what) + { + case UNICODE_2_UTF8: + uni = p->unicode; + for(i=0;i<4;) p->eight_bits[i++] = 0; + + if (uni < 0x7F) + { + p->eight_bits[0] = uni & 0x7F; + p->nchars = 1; + return; + } + else + { + p->eight_bits[0] = uni & 0x3F; + p->eight_bits[0] |= 0x80; + uni >>= 6; + } + + if (uni < 0x20) + { + p->eight_bits[1] = uni & 0x1F; + p->eight_bits[1] |= 0xC0; + p->nchars = 2; + return; + } + else + { + p->eight_bits[1] = uni & 0x3F; + p->eight_bits[1] |= 0x80; + uni >>= 6; + } + + if (uni < 0x10) + { + p->eight_bits[2] = uni & 0xF; + p->eight_bits[2] |= 0xEF; + p->nchars = 3; + return; + } + else + { + p->eight_bits[2] = uni & 0x3F; + p->eight_bits[2] |= 0x80; + uni >>= 6; + } + + p->eight_bits[3] = uni & 0x7; + p->eight_bits[3] |= 0xF0; + p->nchars = 4; + return; + + case UTF8_2_UNICODE: + for(i=p->nchars;i<4;) p->eight_bits[i++] = 0; + if (p->eight_bits[0] < 0x80) + { + p->unicode = p->eight_bits[0]; + return; + } + else + p->unicode = p->eight_bits[0] & 0x3F; + + if (p->eight_bits[1] < 0xE0) + { + p->unicode += (p->eight_bits[1] & 0x1F) << 6; + return; + } + else + p->unicode += (p->eight_bits[1] & 0x3F) << 6; + + if (p->eight_bits[2] < 0xF0) + { + p->unicode += (p->eight_bits[2] & 0xF) << 12; + return; + } + else + p->unicode += (p->eight_bits[2] & 0x3F) << 12; + + p->unicode += (p->eight_bits[3] & 0x7) << 18; + return; + + } + +} + diff --git a/example/example.cabal b/example/example.cabal new file mode 100644 --- /dev/null +++ b/example/example.cabal @@ -0,0 +1,25 @@ +cabal-version: >= 1.2.3 +name: example +synopsis: + Example +description: + Example. +version: 0.2.1 +license: BSD3 +license-file: LICENSE +maintainer: Maurício C. Antunes +author: Maurício C. Antunes +stability: Needs users feedback +build-type: Simple +category: FFI +executable test + main-is: test.hs + hs-source-dirs: . + include-dirs: . + c-sources: example.c + extensions: + ForeignFunctionInterface + ScopedTypeVariables + MultiParamTypeClasses + TypeFamilies + build-depends: base >=3 && <5, bindings-common diff --git a/example/example.h b/example/example.h new file mode 100644 --- /dev/null +++ b/example/example.h @@ -0,0 +1,14 @@ + +#include + +#define UNICODE_2_UTF8 1 +#define UTF8_2_UNICODE 2 + +struct unicode_translator { + uint32_t unicode; + uint8_t eight_bits[4]; + int nchars; +}; + +void translate (int, struct unicode_translator *); + diff --git a/example/test.hsc b/example/test.hsc new file mode 100644 --- /dev/null +++ b/example/test.hsc @@ -0,0 +1,81 @@ +#include +#include "example.h" + +#bindings_initialize + +module Main (main) where +import Foreign +import Foreign.C +import Data.Int +import Data.List +import Control.Monad +import System.IO.Unsafe + +#bindings_num UNICODE_2_UTF8 +#bindings_num UTF8_2_UNICODE + +#bindings_starttype struct unicode_translator +#bindings_field unicode , Word32 +#bindings_array_field eight_bits , Word8 , 4 +#bindings_field nchars , CInt +#bindings_stoptype + +#bindings_function translate , CInt -> Ptr Unicode_translator -> IO () + +toChar :: (Enum a, Enum b) => a -> b +toChar = toEnum . fromEnum +fromChar :: (Enum a, Num b) => a -> b +fromChar = fromIntegral . fromEnum + +unicodeToUtf :: String -> IO String +unicodeToUtf string = liftM concat $ alloca $ \ptrUt -> + (flip mapM) string $ \char -> do + ut <- peek ptrUt + poke ptrUt (ut {unicode_translator'unicode = toChar char}) + translate _UNICODE_2_UTF8 ptrUt + ut <- peek ptrUt + let nChars = fromIntegral $ unicode_translator'nchars ut + let eightBits = unicode_translator'eight_bits ut + return $ (map toChar) $ reverse $ take nChars eightBits + +utfToUnicode :: String -> IO String +utfToUnicode = + (. (map fromChar)) $ + (. splitCodes) $ + mapM $ \c -> do + let ut = Unicode_translator { + unicode_translator'nchars = fromIntegral $ length c, + unicode_translator'eight_bits = reverse $ map fromChar c, + unicode_translator'unicode = 0 + } + unicode <- with ut $ \ptr -> do + translate _UTF8_2_UNICODE ptr + liftM unicode_translator'unicode $ peek ptr + return $ toChar $ unicode + where + splitCodes :: [Word8] -> [[Word8]] + splitCodes [] = [] + splitCodes (a:t) = if (a < 0x80) + then + [a]:(splitCodes t) + else + let i = findIndex (\c -> c < 0x80 || c > 0xBF) t + (t1,t2) = maybe ([],t) (flip splitAt t) i + in (a:t1):(splitCodes t2) + +toUtf8 :: String -> String +toUtf8 = unsafePerformIO . unicodeToUtf + +fromUtf8 :: String -> String +fromUtf8 = unsafePerformIO . utfToUnicode + +printAsInt :: String -> IO () +printAsInt s = putStrLn $ show $ map fromEnum s + +main = do + let a = "Exceção" + printAsInt a + printAsInt $ toUtf8 a + printAsInt $ fromUtf8 $ toUtf8 a + + diff --git a/src/Bindings.hs b/src/Bindings.hs --- a/src/Bindings.hs +++ b/src/Bindings.hs @@ -1,29 +1,281 @@ {-| - Modules under "Bindings" are supposed to be low level - links to well-known libraries. All of them follow the - same style for consistency and predictability. Here are - a few rules that have been followed: + Package @bindings-common@ provides many facilities to + do low-level FFI to C libraris, in the form of macros and modules. + It also sets a base module under which low-level bindings to + C libraries can be inserted. - * All packages use cabal. Checking of dependencies is - delegated to @pkg-config@ by listing such dependencies - in cabal file. +-} - * All names are as close as possible to the names in the - original library language. To agree with Haskell case - conventions they may be prefixed with an underscore or - have their first letter capitalized. +module Bindings ( - * Documentation is provided as links to the official - homepage for a library. Due to the policy of preserving - names and functionality, such documentation can be used - as it is. +-- * Code facilities - These modules are supposed to be used by developers of - higher level modules, who should have a good understanding - of the undeline libraries they decide to use. Of course, - you can use them directly if you know what you are doing. +-- | See documentation for module "Bindings.Utilities". --} +-- * How to wrap a library using this package -module Bindings where {} +-- | If you want to write a comprehensive binding +-- to your favorite library, and you want to try +-- this package to see if it suits your needs, you +-- can look at this documentation and then at the +-- source code for "Bindings.C", which tries to wrap +-- the full standard C library. + +-- * Macros + +-- | Starting from version 0.2, package @bindings-common@ +-- provides many @hsc2hs@ macros to easy C binding. +-- Here we list the most important. + +-- [@#bindings_num@] Makes a C value into a Haskell +-- name with type @(Num a) => a@. Used mostly to +-- copy pre-processor macros. Note that here, as in +-- all other macros, Haskell names are automatically +-- derived from C names. Usage: +-- +-- @ +-- #bindings_num MY_MACRO +-- @ + +-- [@#bindings_int@] Like @#bindings_num@, but values +-- are typed as @CInt@. + +-- [@#bindings_frac@] Like @#bindings_num@, but works +-- with floating point numbers. Values will have type +-- @(Fractional a) => a@. + +-- [@#bindings_function@] Wrap C functions. Usage: +-- +-- @ +-- #bindings_function function_name , CInt -> CString -> IO () +-- @ + +-- [@#bindings_startype , #bindings_stoptype@] Declare a +-- Haskell @data@ type after a C type. You can wrap @struct@s, +-- @union@s and types named with C @typedef@. Note that +-- you can create types with no fields. This may be usefull +-- when you don't need to reach fields, but your API requires +-- you to create values of such types. +-- +-- @ +-- #bindings_starttype struct my_type +-- #bindings_stoptype _ +-- @ +-- +-- You can replace @struct@ with @union@, or remove it +-- when your type is defined with @typedef@. Note that +-- the @_@ after @#bindings_stoptype@ is needed since +-- @hsc2hs@ doesn't accept macros with no parameters. + +-- [@#bindings_field , #bindings_array_field@] Describe fields +-- inside types. Supose you have a @struct@ like this: +-- +-- @ +-- typedef struct my_struct { +-- int index; +-- char *text; +-- char array[10]; +-- } my_struct_t; +-- @ +-- +-- You would mimic such type like this. +-- +-- @ +-- #bindings_starttype my_struct_t +-- #bindings_field index , CInt +-- #bindings_field text , CString +-- #bindings_array_field , array , CChar , 10 +-- #bindings_stoptype _ +-- @ +-- +-- You get a full instance for @Storable@. +-- +-- @ +-- v <- peek p :: IO My_struct_t +-- poke p $ v {my_struct_t'index = 1 + (my_struct_t'index v)} +-- @ +-- +-- As you can see from the example above, field names +-- are translated to Haskell using @type'field@ pattern. +-- This is necessary to avoid name clashes since Haskell +-- would not allow many types with similar records, as +-- is common practice in C. + +-- [@#bindings_equivalent_integer@] This gives you a Haskell +-- integer type that is the same size as a C type. Usage: +-- +-- @ +-- type CIntType = #bindings_equivalent_integer int_type +-- @ +-- +-- This is actually equivalent to @hsc2hs@ +-- @#type@, except that it is safe to use on pointers +-- (but not on floating point types). + +-- [@#bindings_globalvar@] Wraps a global variable, using +-- 'Bindings.Utilities.GlobalVariable'. Usage: +-- +-- @ +-- #bindings_globalvar external_string , CString +-- @ +-- +-- Note that the internal type of that variable +-- will be a pointer to a @CString@, as you'll be +-- allowed to change its value. When touching it +-- using 'Bindings.Utilities.writeGlobalVariable' +-- this is invisible to you. + + +-- * Example + +-- | We'll take a small piece of C code and wrap it +-- using @hsc2hs@ macros available in @bindings-common@. +-- Our intention is to show that we can write Haskell +-- code with the help of existing C code, but using +-- a Haskell interface that is not built on the C +-- interface. This is an alternative to the usual style +-- of using adapted versions of native C calls. In our +-- opinion, the style shown here is easier to write +-- and give results that are more confortable to use +-- in Haskell. + +-- ** C API + +-- | This is a small (artificial, naive and ugly) API +-- for UTF-8 coding of characters. Most APIs have better +-- design, but we just want to show how to deal with it. +-- +-- @ +-- #define UNICODE_2_UTF8 1 +-- #define UTF8_2_UNICODE 2 +-- +-- struct unicode_translator { +-- uint32_t unicode; +-- uint8_t eight_bits[4]; +-- int nchars; +-- }; +-- +-- void translate (int, struct unicode_translator *); +-- @ +-- +-- We use it filling @unicode@ field with an unicode +-- number, and then calling @translate@ with @UNICODE_2_UTF8@; +-- or filling @eight_bits@ and calling @translate@ with +-- @UTF8_2_UNICODE@. + +-- ** Haskell low level binding + +-- | Now we make use of @hsc2hs@ macros inside Haskell. +-- +-- #bindings_num UNICODE_2_UTF8 +-- #bindings_num UTF8_2_UNICODE +-- +-- #bindings_starttype struct unicode_translator +-- #bindings_field unicode , Word32 +-- #bindings_array_field eight_bits , Word8 , 4 +-- #bindings_field nchars , CInt +-- #bindings_stoptype +-- +-- #bindings_function translate , CInt -> Ptr Unicode_translator -> IO () +-- +-- This gives us a set of declarations as below. +-- +-- @ +-- _UNICODE_2_UTF8 :: (Num a) => a +-- _UTF8_2_UNICODE :: (Num a) => a +-- +-- data Unicode_translator = Unicode_translator { +-- unicode_translator'unicode :: Word32, +-- unicode_translator'eight_bits :: [Word8], +-- unicode_translator'nchars :: CInt +-- } +-- +-- translate :: CInt -> Ptr Unicode_translator -> IO () +-- @ + +-- ** Clean Haskell code + +-- | Now we declare a few Haskell utilities that +-- better fit Haskell programming. +-- +-- @ +-- toChar :: (Enum a, Enum b) => a -> b +-- toChar = toEnum . fromEnum +-- fromChar :: (Enum a, Num b) => a -> b +-- fromChar = fromIntegral . fromEnum +-- +-- unicodeToUtf :: String -> IO String +-- unicodeToUtf string = liftM concat $ alloca $ \ptrUt -> +-- (flip mapM) string $ \char -> do +-- ut <- peek ptrUt +-- poke ptrUt (ut {unicode_translator'unicode = toChar char}) +-- translate _UNICODE_2_UTF8 ptrUt +-- ut <- peek ptrUt +-- let nChars = fromIntegral $ unicode_translator'nchars ut +-- let eightBits = unicode_translator'eight_bits ut +-- return $ (map toChar) $ reverse $ take nChars eightBits +-- +-- utfToUnicode :: String -> IO String +-- utfToUnicode = +-- (. (map fromChar)) $ +-- (. splitCodes) $ +-- mapM $ \c -> do +-- let ut = Unicode_translator { +-- unicode_translator'nchars = fromIntegral $ length c, +-- unicode_translator'eight_bits = reverse $ map fromChar c, +-- unicode_translator'unicode = 0 +-- } +-- unicode <- with ut $ \ptr -> do +-- translate _UTF8_2_UNICODE ptr +-- liftM unicode_translator'unicode $ peek ptr +-- return $ toChar $ unicode +-- where +-- splitCodes :: [Word8] -> [[Word8]] +-- splitCodes [] = [] +-- splitCodes (a:t) = if (a < 0x80) +-- then +-- [a]:(splitCodes t) +-- else +-- let i = findIndex (\c -> c < 0x80 || c > 0xBF) t +-- (t1,t2) = maybe ([],t) (flip splitAt t) i +-- in (a:t1):(splitCodes t2) +-- @ +-- +-- @unicodeToUtf@ and @utfToUnicode@ now use Haskell +-- day-to-day types. + +-- ** Better interface + +-- | Our functions are effect-free. +-- +-- @ +-- toUtf8 :: String -> String +-- toUtf8 = unsafePerformIO . unicodeToUtf +-- +-- fromUtf8 :: String -> String +-- fromUtf8 = unsafePerformIO . utfToUnicode +-- @ +-- +-- And this is something we can confortably use. +-- +-- @ +-- printAsInt :: String -> IO () +-- printAsInt s = putStrLn $ show $ map fromEnum s +-- +-- main = do +-- let a = "Exceção" +-- printAsInt a +-- printAsInt $ toUtf8 a +-- printAsInt $ fromUtf8 $ toUtf8 a +-- @ +-- +-- Outputs: +-- +-- @ +-- [69,120,99,101,231,227,111] +-- [69,120,99,101,195,167,195,163,111] +-- [69,120,99,101,231,227,111] +-- @ + + ) where {} diff --git a/src/bindings.macros.h b/src/bindings.macros.h --- a/src/bindings.macros.h +++ b/src/bindings.macros.h @@ -117,6 +117,8 @@ int nfields = 0; \ char *fieldnames[100]; \ char *fieldtypes[100]; \ + int is_array[100]; \ + int array_size[100]; \ size_t fieldoffsets[100]; \ size_t typesize = sizeof (name); \ int i; \ @@ -126,17 +128,26 @@ #define hsc_bindings_field(name,type) \ fieldnames[nfields] = # name; \ fieldtypes[nfields] = # type; \ + is_array[nfields] = 0; \ fieldoffsets[nfields] = (size_t) &(refpointer->name); \ nfields++; +#define hsc_bindings_array_field(name,type,size) \ + fieldnames[nfields] = # name; \ + fieldtypes[nfields] = # type; \ + is_array[nfields] = 1; \ + array_size[nfields] = size; \ + fieldoffsets[nfields] = (size_t) (refpointer->name); \ + nfields++; + #define hsc_bindings_stoptype(dummy) \ printf("data %s = %s", bindings_conid(type1), \ bindings_conid(type1)); \ if (nfields>0) printf (" {"); \ for(i=0;i0) printf ("}"); \ @@ -145,16 +156,25 @@ typesize); \ for(i=0;i>= \\v%d -> ", \ - fieldoffsets[i],i); \ + if (is_array[i]) \ + printf("peekArray %d (plusPtr p %zu) >>= \\v%d -> ", \ + array_size[i],fieldoffsets[i],i); \ + else \ + printf("peekByteOff p %zu >>= \\v%d -> ", \ + fieldoffsets[i],i); \ } \ printf("return $ %s ",bindings_conid(type1)); \ for(i=0;i> ", \ - fieldoffsets[i],i); \ + for(i=0;i> ", \ + fieldoffsets[i],array_size[i],i); \ + else \ + printf("pokeByteOff p %zu v%d >> ", \ + fieldoffsets[i],i); \ printf("return () }"); \ }