|
| 1 | +-- C->Haskell Compiler: Marshalling library |
| 2 | +-- |
| 3 | +-- Copyright (c) [1999...2005] Manuel M T Chakravarty |
| 4 | +-- |
| 5 | +-- Redistribution and use in source and binary forms, with or without |
| 6 | +-- modification, are permitted provided that the following conditions are met: |
| 7 | +-- |
| 8 | +-- 1. Redistributions of source code must retain the above copyright notice, |
| 9 | +-- this list of conditions and the following disclaimer. |
| 10 | +-- 2. Redistributions in binary form must reproduce the above copyright |
| 11 | +-- notice, this list of conditions and the following disclaimer in the |
| 12 | +-- documentation and/or other materials provided with the distribution. |
| 13 | +-- 3. The name of the author may not be used to endorse or promote products |
| 14 | +-- derived from this software without specific prior written permission. |
| 15 | +-- |
| 16 | +-- THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR |
| 17 | +-- IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES |
| 18 | +-- OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN |
| 19 | +-- NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, |
| 20 | +-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED |
| 21 | +-- TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR |
| 22 | +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF |
| 23 | +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING |
| 24 | +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS |
| 25 | +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. |
| 26 | +-- |
| 27 | +--- Description --------------------------------------------------------------- |
| 28 | +-- |
| 29 | +-- Language: Haskell 98 |
| 30 | +-- |
| 31 | +-- This module provides the marshaling routines for Haskell files produced by |
| 32 | +-- C->Haskell for binding to C library interfaces. It exports all of the |
| 33 | +-- low-level FFI (language-independent plus the C-specific parts) together |
| 34 | +-- with the C->HS-specific higher-level marshalling routines. |
| 35 | +-- |
| 36 | + |
| 37 | +module C2HS ( |
| 38 | + |
| 39 | + -- * Re-export the language-independent component of the FFI |
| 40 | + module Foreign, |
| 41 | + |
| 42 | + -- * Re-export the C language component of the FFI |
| 43 | + module CForeign, |
| 44 | + |
| 45 | + -- * Composite marshalling functions |
| 46 | + withCStringLenIntConv, peekCStringLenIntConv, withIntConv, withFloatConv, |
| 47 | + peekIntConv, peekFloatConv, withBool, peekBool, withEnum, peekEnum, |
| 48 | + |
| 49 | + -- * Conditional results using 'Maybe' |
| 50 | + nothingIf, nothingIfNull, |
| 51 | + |
| 52 | + -- * Bit masks |
| 53 | + combineBitMasks, containsBitMask, extractBitMasks, |
| 54 | + |
| 55 | + -- * Conversion between C and Haskell types |
| 56 | + cIntConv, cFloatConv, cToBool, cFromBool, cToEnum, cFromEnum |
| 57 | +) where |
| 58 | + |
| 59 | + |
| 60 | +import Foreign |
| 61 | + hiding (Word) |
| 62 | + -- Should also hide the Foreign.Marshal.Pool exports in |
| 63 | + -- compilers that export them |
| 64 | +import CForeign |
| 65 | + |
| 66 | +import Monad (when, liftM) |
| 67 | + |
| 68 | + |
| 69 | +-- Composite marshalling functions |
| 70 | +-- ------------------------------- |
| 71 | + |
| 72 | +-- Strings with explicit length |
| 73 | +-- |
| 74 | +withCStringLenIntConv s f = withCStringLen s $ \(p, n) -> f (p, cIntConv n) |
| 75 | +peekCStringLenIntConv (s, n) = peekCStringLen (s, cIntConv n) |
| 76 | + |
| 77 | +-- Marshalling of numerals |
| 78 | +-- |
| 79 | + |
| 80 | +withIntConv :: (Storable b, Integral a, Integral b) |
| 81 | + => a -> (Ptr b -> IO c) -> IO c |
| 82 | +withIntConv = with . cIntConv |
| 83 | + |
| 84 | +withFloatConv :: (Storable b, RealFloat a, RealFloat b) |
| 85 | + => a -> (Ptr b -> IO c) -> IO c |
| 86 | +withFloatConv = with . cFloatConv |
| 87 | + |
| 88 | +peekIntConv :: (Storable a, Integral a, Integral b) |
| 89 | + => Ptr a -> IO b |
| 90 | +peekIntConv = liftM cIntConv . peek |
| 91 | + |
| 92 | +peekFloatConv :: (Storable a, RealFloat a, RealFloat b) |
| 93 | + => Ptr a -> IO b |
| 94 | +peekFloatConv = liftM cFloatConv . peek |
| 95 | + |
| 96 | +-- Passing Booleans by reference |
| 97 | +-- |
| 98 | + |
| 99 | +withBool :: (Integral a, Storable a) => Bool -> (Ptr a -> IO b) -> IO b |
| 100 | +withBool = with . fromBool |
| 101 | + |
| 102 | +peekBool :: (Integral a, Storable a) => Ptr a -> IO Bool |
| 103 | +peekBool = liftM toBool . peek |
| 104 | + |
| 105 | + |
| 106 | +-- Passing enums by reference |
| 107 | +-- |
| 108 | + |
| 109 | +withEnum :: (Enum a, Integral b, Storable b) => a -> (Ptr b -> IO c) -> IO c |
| 110 | +withEnum = with . cFromEnum |
| 111 | + |
| 112 | +peekEnum :: (Enum a, Integral b, Storable b) => Ptr b -> IO a |
| 113 | +peekEnum = liftM cToEnum . peek |
| 114 | + |
| 115 | + |
| 116 | +-- Storing of 'Maybe' values |
| 117 | +-- ------------------------- |
| 118 | + |
| 119 | +instance Storable a => Storable (Maybe a) where |
| 120 | + sizeOf _ = sizeOf (undefined :: Ptr ()) |
| 121 | + alignment _ = alignment (undefined :: Ptr ()) |
| 122 | + |
| 123 | + peek p = do |
| 124 | + ptr <- peek (castPtr p) |
| 125 | + if ptr == nullPtr |
| 126 | + then return Nothing |
| 127 | + else liftM Just $ peek ptr |
| 128 | + |
| 129 | + poke p v = do |
| 130 | + ptr <- case v of |
| 131 | + Nothing -> return nullPtr |
| 132 | + Just v' -> new v' |
| 133 | + poke (castPtr p) ptr |
| 134 | + |
| 135 | + |
| 136 | +-- Conditional results using 'Maybe' |
| 137 | +-- --------------------------------- |
| 138 | + |
| 139 | +-- Wrap the result into a 'Maybe' type. |
| 140 | +-- |
| 141 | +-- * the predicate determines when the result is considered to be non-existing, |
| 142 | +-- ie, it is represented by `Nothing' |
| 143 | +-- |
| 144 | +-- * the second argument allows to map a result wrapped into `Just' to some |
| 145 | +-- other domain |
| 146 | +-- |
| 147 | +nothingIf :: (a -> Bool) -> (a -> b) -> a -> Maybe b |
| 148 | +nothingIf p f x = if p x then Nothing else Just $ f x |
| 149 | + |
| 150 | +-- |Instance for special casing null pointers. |
| 151 | +-- |
| 152 | +nothingIfNull :: (Ptr a -> b) -> Ptr a -> Maybe b |
| 153 | +nothingIfNull = nothingIf (== nullPtr) |
| 154 | + |
| 155 | + |
| 156 | +-- Support for bit masks |
| 157 | +-- --------------------- |
| 158 | + |
| 159 | +-- Given a list of enumeration values that represent bit masks, combine these |
| 160 | +-- masks using bitwise disjunction. |
| 161 | +-- |
| 162 | +combineBitMasks :: (Enum a, Bits b) => [a] -> b |
| 163 | +combineBitMasks = foldl (.|.) 0 . map (fromIntegral . fromEnum) |
| 164 | + |
| 165 | +-- Tests whether the given bit mask is contained in the given bit pattern |
| 166 | +-- (i.e., all bits set in the mask are also set in the pattern). |
| 167 | +-- |
| 168 | +containsBitMask :: (Bits a, Enum b) => a -> b -> Bool |
| 169 | +bits `containsBitMask` bm = let bm' = fromIntegral . fromEnum $ bm |
| 170 | + in |
| 171 | + bm' .&. bits == bm' |
| 172 | + |
| 173 | +-- |Given a bit pattern, yield all bit masks that it contains. |
| 174 | +-- |
| 175 | +-- * This does *not* attempt to compute a minimal set of bit masks that when |
| 176 | +-- combined yield the bit pattern, instead all contained bit masks are |
| 177 | +-- produced. |
| 178 | +-- |
| 179 | +extractBitMasks :: (Bits a, Enum b, Bounded b) => a -> [b] |
| 180 | +extractBitMasks bits = |
| 181 | + [bm | bm <- [minBound..maxBound], bits `containsBitMask` bm] |
| 182 | + |
| 183 | + |
| 184 | +-- Conversion routines |
| 185 | +-- ------------------- |
| 186 | + |
| 187 | +-- |Integral conversion |
| 188 | +-- |
| 189 | +cIntConv :: (Integral a, Integral b) => a -> b |
| 190 | +cIntConv = fromIntegral |
| 191 | + |
| 192 | +-- |Floating conversion |
| 193 | +-- |
| 194 | +cFloatConv :: (RealFloat a, RealFloat b) => a -> b |
| 195 | +cFloatConv = realToFrac |
| 196 | +-- As this conversion by default goes via `Rational', it can be very slow... |
| 197 | +{-# RULES |
| 198 | + "cFloatConv/Float->Float" forall (x::Float). cFloatConv x = x; |
| 199 | + "cFloatConv/Double->Double" forall (x::Double). cFloatConv x = x |
| 200 | + #-} |
| 201 | + |
| 202 | +-- |Obtain C value from Haskell 'Bool'. |
| 203 | +-- |
| 204 | +cFromBool :: Num a => Bool -> a |
| 205 | +cFromBool = fromBool |
| 206 | + |
| 207 | +-- |Obtain Haskell 'Bool' from C value. |
| 208 | +-- |
| 209 | +cToBool :: Num a => a -> Bool |
| 210 | +cToBool = toBool |
| 211 | + |
| 212 | +-- |Convert a C enumeration to Haskell. |
| 213 | +-- |
| 214 | +cToEnum :: (Integral i, Enum e) => i -> e |
| 215 | +cToEnum = toEnum . cIntConv |
| 216 | + |
| 217 | +-- |Convert a Haskell enumeration to C. |
| 218 | +-- |
| 219 | +cFromEnum :: (Enum e, Integral i) => e -> i |
| 220 | +cFromEnum = cIntConv . fromEnum |
0 commit comments