├── .gitignore ├── LICENSE ├── Language └── C │ └── Inline │ ├── C.hs │ ├── C │ ├── Hint.hs │ └── Marshal.hs │ ├── Error.hs │ ├── Hint.hs │ ├── ObjC.hs │ ├── ObjC │ ├── Hint.hs │ └── Marshal.hs │ ├── State.hs │ └── TH.hs ├── Makefile ├── README.md ├── Setup.hs ├── Test └── PosixC.hs ├── language-c-inline.cabal └── tests ├── dummy.hs ├── objc ├── app │ ├── App.hs │ ├── AppDelegate.hs │ ├── HSApp-xcode-prj │ │ ├── HSApp.xcodeproj │ │ │ └── project.pbxproj │ │ └── HSApp │ │ │ ├── AppDelegate.h │ │ │ ├── AppDelegate.m │ │ │ ├── HSApp-Info.plist │ │ │ ├── HSApp-Prefix.pch │ │ │ ├── en.lproj │ │ │ ├── Credits.rtf │ │ │ ├── InfoPlist.strings │ │ │ └── MainMenu.xib │ │ │ └── main.m │ ├── HSApp.app │ │ └── Contents │ │ │ ├── Info.plist │ │ │ ├── MacOS │ │ │ └── .gitkeep │ │ │ └── Resources │ │ │ └── en.lproj │ │ │ ├── Credits.rtf │ │ │ ├── InfoPlist.strings │ │ │ └── MainMenu.nib │ ├── Interpreter.hs │ ├── Main.hs │ ├── Makefile │ └── Readme.md ├── concept │ ├── MainInlineObjC.hs │ ├── Makefile │ └── TestInlineObjC.hs ├── marshal-array │ ├── Main.hs │ └── Makefile ├── minimal │ ├── Main.hs │ └── Makefile └── record │ ├── Main.hs │ ├── Makefile │ └── Particle.hs └── testsuite.hs /.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | *.hi 3 | *.dyn_* 4 | 5 | /dist/ 6 | tests/objc/InlineObjC 7 | 8 | tests/objc/TestInlineObjC_objc.m 9 | 10 | tests/objc/concept/TestInlineObjC_objc.m 11 | 12 | tests/objc/concept/InlineObjC 13 | 14 | tests/objc/app/App_objc.m 15 | 16 | tests/objc/app/HSApp 17 | 18 | tests/objc/app/HSApp.app/Contents/MacOS/HSApp 19 | 20 | tests/objc/app/AppDelegate_objc.h 21 | 22 | tests/objc/app/AppDelegate_objc.m 23 | 24 | tests/objc/app/App_objc.h 25 | 26 | tests/objc/concept/TestInlineObjC_objc.h 27 | 28 | tests/objc/app/AppDelegate_stub.h 29 | 30 | # Xcode (courtesy of github/Mantle) 31 | build/* 32 | *.pbxuser 33 | !default.pbxuser 34 | *.mode1v3 35 | !default.mode1v3 36 | *.mode2v3 37 | !default.mode2v3 38 | *.perspectivev3 39 | !default.perspectivev3 40 | *.xcworkspace 41 | !default.xcworkspace 42 | xcuserdata 43 | profile 44 | *.moved-aside 45 | # Desktop Servies 46 | .DS_Store 47 | 48 | tests/objc/minimal/Main_objc.h 49 | 50 | tests/objc/minimal/Main_objc.m 51 | 52 | tests/objc/minimal/Minimal 53 | 54 | tests/objc/record/Main_objc.h 55 | 56 | tests/objc/record/Main_objc.m 57 | 58 | tests/objc/record/Particle 59 | 60 | tests/objc/record/Particle_objc.h 61 | 62 | tests/objc/record/Particle_objc.m 63 | 64 | tests/objc/record/Particle_stub.h 65 | 66 | *.orig 67 | 68 | tests/objc/marshal-array/Main_objc.h 69 | 70 | tests/objc/marshal-array/Main_objc.m 71 | 72 | tests/objc/marshal-array/MarshalArray 73 | 74 | *_c.[ch] 75 | testsuite 76 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) [2013..2014] Manuel M T Chakravarty. All rights reserved. 2 | 3 | Redistribution and use in source and binary forms, with or without 4 | modification, are permitted provided that the following conditions are met: 5 | * Redistributions of source code must retain the above copyright 6 | notice, this list of conditions and the following disclaimer. 7 | * Redistributions in binary form must reproduce the above copyright 8 | notice, this list of conditions and the following disclaimer in the 9 | documentation and/or other materials provided with the distribution. 10 | * Neither the names of the contributors nor of their affiliations may 11 | be used to endorse or promote products derived from this software 12 | without specific prior written permission. 13 | 14 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS ''AS IS'' AND ANY 15 | EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 16 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 17 | DISCLAIMED. IN NO EVENT SHALL COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 19 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 20 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 21 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 22 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 23 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 24 | -------------------------------------------------------------------------------- /Language/C/Inline/C.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, QuasiQuotes #-} 2 | 3 | -- | 4 | -- Module : Language.C.Inline.C 5 | -- Copyright : [2013] Manuel M T Chakravarty 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Manuel M T Chakravarty 9 | -- Stability : experimental 10 | -- Portability : non-portable (GHC extensions) 11 | -- 12 | -- This module exports the principal API for inline C. 13 | 14 | module Language.C.Inline.C ( 15 | 16 | -- * Re-export types from 'Foreign.C' 17 | module Foreign.C.Types, CString, CStringLen, CWString, CWStringLen, Errno, ForeignPtr, castForeignPtr, 18 | 19 | -- * Re-export types from Template Haskell 20 | Name, 21 | 22 | -- * Combinators for inline Objective-C 23 | c_import, c_interface, c_implementation, c_typecheck, c, c_emit, 24 | 25 | -- * Marshalling annotations 26 | Annotated(..), (<:), void, Class(..), IsType, 27 | 28 | ) where 29 | 30 | -- common libraries 31 | import Control.Applicative 32 | import Control.Monad hiding (void) 33 | import Data.Array 34 | import Data.Dynamic 35 | import Data.IORef 36 | import Data.List 37 | import Data.Maybe 38 | import Foreign.C as C 39 | import Foreign.C.Types 40 | import Foreign.ForeignPtr as C 41 | import Language.Haskell.TH as TH 42 | import Language.Haskell.TH.Syntax as TH 43 | import System.FilePath 44 | import System.IO.Unsafe (unsafePerformIO) 45 | 46 | -- quasi-quotation libraries 47 | import Language.C.Quote as QC 48 | import Language.C.Quote.C as QC 49 | import Text.PrettyPrint.Mainland as QC 50 | 51 | -- friends 52 | import Language.C.Inline.Error 53 | import Language.C.Inline.Hint 54 | import Language.C.Inline.State 55 | import Language.C.Inline.C.Hint 56 | import Language.C.Inline.C.Marshal 57 | 58 | 59 | -- |Specify imported Objective-C files. Needs to be spliced where an import declaration can appear. (Just put it 60 | -- straight after all the import statements in the module.) 61 | -- 62 | -- FIXME: need to use TH.addDependentFile on each of the imported ObjC files & read headers 63 | -- 64 | c_import :: [FilePath] -> Q [TH.Dec] 65 | c_import headers 66 | = do 67 | { mapM_ stashHeader headers 68 | ; c_jumptable <- newName "c_jumptable" 69 | ; setForeignTable $ varE c_jumptable 70 | ; sequence $ [ sigD c_jumptable [t|IORef (Array Int Dynamic)|] 71 | , pragInlD c_jumptable NoInline FunLike AllPhases -- reqs template-haskell 2.8.0.0 72 | -- , pragInlD c_jumptable (inlineSpecNoPhase False False) 73 | , valD (varP c_jumptable) (normalB [|unsafePerformIO $ newIORef (array (0, 0) [])|]) [] 74 | ] 75 | -- ; return $ [d|import Language.C.Quote as ObjC; 76 | -- import Language.C.Quote.ObjC as ObjC; 77 | -- import Foreign.C as C 78 | -- |] 79 | } 80 | -- FIXME: Should this also add the Language.C.Quote imports? (We might not need to generate any imports at all?!?) 81 | 82 | -- |Inline Objective-C top-level definitions for a header file ('.h'). 83 | -- 84 | c_interface :: [QC.Definition] -> Q [TH.Dec] 85 | c_interface defs 86 | = do 87 | { stashObjC_h defs 88 | ; return [] 89 | } 90 | 91 | -- |Inline C top-level definitions for an implementation file ('.c'). 92 | -- 93 | -- The top-level Haskell variables given in the first argument will be foreign exported to be accessed from the 94 | -- generated Objective-C code. In C, these Haskell variables will always be represented as functions. (In particular, if 95 | -- the Haskell variable refers to a CAF, it will be a nullary function in C — after all, a thunk may still need to be 96 | -- evaluated.) 97 | -- 98 | c_implementation :: [Annotated TH.Name] -> [QC.Definition] -> Q [TH.Dec] 99 | c_implementation ann_vars defs 100 | = do 101 | { mapM_ exportVar ann_vars 102 | ; stashObjC_m defs 103 | ; return [] 104 | } 105 | where 106 | exportVar ann_var 107 | = do 108 | { -- Determine the argument and result types of the exported Haskell function 109 | ; let var = stripAnnotation ann_var 110 | ; (tvs, argTys, inIO, resTy) <- splitHaskellType <$> haskellTypeOf ann_var 111 | 112 | -- Determine C types 113 | ; maybe_cArgTys <- mapM (haskellTypeToCType C11) argTys 114 | ; maybe_cResTy <- haskellTypeToCType C11 resTy 115 | ; let cannotMapAllTypes = Nothing `elem` (maybe_cResTy : maybe_cArgTys) 116 | cArgTys = map maybeErrorCtype maybe_cArgTys 117 | cResTy = maybeErrorCtype maybe_cResTy 118 | 119 | ; if cannotMapAllTypes 120 | then do {str <- annotatedShowQ ann_var; reportErrorWithLang C11 $ "invalid marshalling: " ++ str} 121 | else do 122 | 123 | { -- Determine the bridging type and the marshalling code 124 | ; (bridgeArgTys, cBridgeArgTys, hsArgMarshallers, cArgMarshallers) <- 125 | unzip4 <$> zipWithM generateCToHaskellMarshaller argTys cArgTys 126 | ; (bridgeResTy, cBridgeResTy, hsResMarshaller, cResMarshaller) <- generateHaskellToCMarshaller resTy cResTy 127 | 128 | -- Haskell type of the foreign wrapper function 129 | ; let hsWrapperTy = haskellWrapperType tvs bridgeArgTys bridgeResTy 130 | 131 | -- Generate the Haskell wrapper 132 | ; let cwrapperName = mkName . nameBase $ var 133 | ; hswrapperName <- newName (nameBase var ++ "_hswrapper") 134 | ; hsArgVars <- mapM (const $ newName "arg") bridgeArgTys 135 | ; stashHS 136 | [ forExpD CCall (show hswrapperName) hswrapperName hsWrapperTy 137 | , sigD hswrapperName hsWrapperTy 138 | , funD hswrapperName 139 | [ clause (map varP hsArgVars) 140 | (normalB $ generateHSCall hsArgVars hsArgMarshallers (varE var) hsResMarshaller inIO) 141 | [] 142 | ] 143 | ] 144 | 145 | -- Generate the C wrapper code (both prototype and definition) 146 | ; cArgVars <- mapM (\n -> newName $ "arg" ++ show n) [1..length cBridgeArgTys] 147 | ; let cArgVarExps = [ [cexp| $id:(nameBase var') |] | var' <- cArgVars] 148 | call = [cexp| $id:(show hswrapperName) ( $args:cArgVarExps ) |] 149 | (_wrapperProto, wrapperDef) 150 | = generateCWrapper cwrapperName cBridgeArgTys cArgVars cArgMarshallers cArgTys cArgVars 151 | call 152 | resTy cBridgeResTy cResMarshaller cResTy 153 | ; stashObjC_m $ 154 | -- C prototype of the foreign exported Haskell-side wrapper 155 | [cunit| 156 | $ty:cBridgeResTy $id:(show hswrapperName) ($params:(cParams cBridgeArgTys cArgVars)); 157 | |] 158 | ++ 159 | map makeStaticFunc wrapperDef 160 | } } 161 | 162 | splitHaskellType (ForallT tvs _ctxt ty) -- collect quantified variables (drop the context) 163 | = let (tvs', args, inIO, res) = splitHaskellType ty 164 | in 165 | (tvs ++ tvs', args, inIO, res) 166 | splitHaskellType (ArrowT `AppT` arg `AppT` res) -- collect argument types 167 | = let (tvs, args, inIO, res') = splitHaskellType res 168 | in 169 | (tvs, arg:args, inIO, res') 170 | splitHaskellType (ConT io `AppT` res) | io == ''IO -- is it an 'IO' function? 171 | = ([], [], True, res) 172 | splitHaskellType res 173 | = ([], [], False, res) 174 | 175 | makeStaticFunc (FuncDef (Func dspec f decl ps body loc1) loc2) 176 | = FuncDef (Func (addStatic dspec) f decl ps body loc1) loc2 177 | makeStaticFunc (FuncDef (OldFunc dspec f decl ps ig body loc1) loc2) 178 | = FuncDef (OldFunc (addStatic dspec) f decl ps ig body loc1) loc2 179 | makeStaticFunc def = def 180 | 181 | addStatic (DeclSpec st tqs ts loc) = DeclSpec (Tstatic loc:st) tqs ts loc 182 | addStatic (AntiTypeDeclSpec st tqs ts loc) = AntiTypeDeclSpec (Tstatic loc:st) tqs ts loc 183 | addStatic declSpec = declSpec 184 | 185 | maybeErrorCtype :: Maybe QC.Type -> QC.Type 186 | maybeErrorCtype Nothing = [cty| typename __UNDEFINED_TYPE |] -- placeholder to make progress in the face of errors 187 | maybeErrorCtype (Just ty) = ty 188 | 189 | forExpD :: Callconv -> String -> Name -> TypeQ -> DecQ 190 | forExpD cc str n ty 191 | = do 192 | { ty' <- ty 193 | ; return $ ForeignD (ExportF cc str n ty') 194 | } 195 | 196 | 197 | -- |Inline C expression. 198 | -- 199 | -- The inline expression will be wrapped in a C function whose arguments are marshalled versions of the Haskell 200 | -- variables given in the first argument. The marshalling of the variables and of the result is determined by the 201 | -- marshalling annotations at the variables and the inline expression. 202 | -- 203 | c :: [Annotated TH.Name] -> Annotated QC.Exp -> Q TH.Exp 204 | c ann_vars ann_e 205 | = {- tryWithPlaceholder $ -} do -- FIXME: catching the 'fail' purges all reported errors :( 206 | { -- Sanity check of arguments 207 | ; let vars = map stripAnnotation ann_vars 208 | ; varTys <- mapM haskellTypeOf ann_vars 209 | ; resTy <- haskellTypeOf ann_e 210 | 211 | -- Determine C types 212 | ; maybe_cArgTys <- mapM annotatedHaskellTypeToCType ann_vars 213 | ; maybe_cResTy <- annotatedHaskellTypeToCType ann_e 214 | ; let cannotMapAllTypes = Nothing `elem` (maybe_cResTy : maybe_cArgTys) 215 | cArgTys = map maybeErrorCtype maybe_cArgTys 216 | cResTy = maybeErrorCtype maybe_cResTy 217 | 218 | ; if cannotMapAllTypes 219 | then failOn [ann_var | (ann_var, Nothing) <- zip ann_vars maybe_cArgTys] maybe_cResTy 220 | else do 221 | 222 | { -- Determine the bridging type and the marshalling code 223 | ; (bridgeArgTys, cBridgeArgTys, hsArgMarshallers, cArgMarshallers) <- 224 | unzip4 <$> zipWithM generateHaskellToCMarshaller varTys cArgTys 225 | ; (bridgeResTy, cBridgeResTy, hsResMarshaller, cResMarshaller) <- 226 | generateCToHaskellMarshaller resTy cResTy 227 | 228 | -- Haskell type of the foreign wrapper function 229 | ; let hsWrapperTy = haskellWrapperType [] bridgeArgTys bridgeResTy 230 | 231 | -- FFI setup for the C wrapper 232 | ; cwrapperName <- show <$> newName "cwrapper" >>= newName -- Don't ask... 233 | ; stashHS 234 | [ forImpD CCall Safe (show cwrapperName) cwrapperName hsWrapperTy 235 | ] 236 | ; idx <- extendJumpTable cwrapperName 237 | 238 | -- Generate the C wrapper code (both prototype and definition) 239 | ; cArgVars <- mapM (newName . nameBase) vars 240 | ; let (wrapperProto, wrapperDef) 241 | = generateCWrapper cwrapperName cArgTys vars cArgMarshallers cBridgeArgTys cArgVars 242 | (stripAnnotation ann_e) 243 | resTy cResTy cResMarshaller cBridgeResTy 244 | ; stashObjC_h wrapperProto 245 | ; stashObjC_m wrapperDef 246 | 247 | -- Generate invocation of the C wrapper sandwiched into Haskell-side marshalling 248 | ; generateHSCall vars hsArgMarshallers (callThroughTable idx hsWrapperTy) hsResMarshaller True 249 | } } 250 | where 251 | callThroughTable idx ty 252 | = do { jumptable <- getForeignTable 253 | ; [|fromDyn 254 | ((unsafePerformIO $ readIORef $jumptable) ! $(TH.lift idx)) 255 | (error "InlineC: INTERNAL ERROR: type mismatch in jumptable") 256 | :: $ty |] 257 | } 258 | 259 | failOn err_ann_vars maybe_cResTy 260 | = do 261 | { unless (null err_ann_vars) $ do 262 | { var_strs <- mapM annotatedShowQ err_ann_vars 263 | ; reportErrorWithLang C11 $ "invalid marshalling: " ++ intercalate ", " var_strs 264 | } 265 | ; unless (isJust maybe_cResTy) $ do 266 | { ty <- haskellTypeOf ann_e 267 | ; reportErrorWithLang C11 $ "invalid marshalling for result type " ++ show ty 268 | } 269 | ; [| error "error in inline Objective-C expression" |] 270 | } 271 | 272 | annotatedHaskellTypeToCType ann 273 | = do 274 | { maybe_cType <- foreignTypeOf ann 275 | ; case maybe_cType of 276 | Nothing -> haskellTypeOf ann >>= haskellTypeToCType C11 277 | Just cType -> return $ Just cType 278 | } 279 | 280 | -- Turn a list of argument types and a result type into a Haskell wrapper signature. 281 | -- 282 | -- > haskellWrapperType [tv1, .., tvm] [a1, .., an] r = [| forall tv1 .. tvm. a1 -> .. -> an -> IO r |] 283 | -- 284 | haskellWrapperType :: [TH.TyVarBndr] -> [TH.TypeQ] -> TH.TypeQ -> TH.TypeQ 285 | haskellWrapperType [] argTys resTy = wrapperBodyType argTys resTy -- monotype 286 | haskellWrapperType tvs argTys resTy = forallT tvs (cxt []) (wrapperBodyType argTys resTy) -- polytype 287 | 288 | wrapperBodyType :: [TH.TypeQ] -> TH.TypeQ -> TH.TypeQ 289 | wrapperBodyType [] resTy = [t| IO $resTy |] 290 | wrapperBodyType (argTy:argTys) resTy = [t| $argTy -> $(wrapperBodyType argTys resTy) |] 291 | 292 | -- Generate the prototype of and function definition of a C marshalling wrapper. 293 | -- 294 | -- Given a C expression to be executed, this generator produces a C function that executes the expression with all 295 | -- arguments and the result marshalled using the provided marshallers. 296 | -- 297 | generateCWrapper :: TH.Name 298 | -> [QC.Type] 299 | -> [TH.Name] -- name of arguments after marshalling (will be the original name without unique) 300 | -> [CMarshaller] 301 | -> [QC.Type] 302 | -> [TH.Name] 303 | -> QC.Exp -- C expression containing occurences of the arguments (using names without uniques) 304 | -> TH.Type 305 | -> QC.Type 306 | -> CMarshaller 307 | -> QC.Type 308 | -> ([QC.Definition], [QC.Definition]) 309 | generateCWrapper cwrapperName argTys vars argMarshallers cWrapperArgTys argVars e hsResTy resTy resMarshaller cWrapperResTy 310 | = let cMarshalling = [ [citem| $ty:argTy $id:(nameBase var) = $exp:(argMarshaller argVar); |] 311 | | (argTy, var, argMarshaller, argVar) <- zip4 argTys vars argMarshallers argVars] 312 | resultName = mkName "result" 313 | cInvocation | hsResTy == (ConT ''()) = [citem| $exp:e; |] -- void result 314 | | otherwise = [citem| { 315 | $ty:resTy $id:(show resultName) = $exp:e; // non-void result... 316 | return $exp:(resMarshaller resultName); // ...marshalled to Haskell 317 | }|] 318 | in 319 | ([cunit| 320 | $ty:cWrapperResTy $id:(show cwrapperName) ($params:(cParams cWrapperArgTys argVars)); 321 | |], 322 | [cunit| 323 | $ty:cWrapperResTy $id:(show cwrapperName) ($params:(cParams cWrapperArgTys argVars)) 324 | { 325 | $items:cMarshalling 326 | $item:cInvocation 327 | } 328 | |]) 329 | 330 | -- cParams [a1, .., an] [v1, .., vn] = [[cparam| a1 v1 |], .., [cparam| an vn |]] 331 | -- 332 | -- * If the list is empty, we will return a singleton 'void' parameter. 333 | -- 334 | cParams :: [QC.Type] -> [TH.Name] -> [QC.Param] 335 | cParams [] [] = [ [cparam| void |] ] 336 | cParams tys names = cParams' tys names 337 | where 338 | cParams' [] [] = [] 339 | cParams' (argTy:argTys) (var:vars) = [cparam| $ty:argTy $id:(show var) |] : cParams' argTys vars 340 | 341 | 342 | -- Produce a Haskell expression that calls a function with all arguments and the result marshalled with the supplied 343 | -- marshallers. 344 | -- 345 | generateHSCall :: [TH.Name] 346 | -> [HaskellMarshaller] 347 | -> TH.ExpQ 348 | -> HaskellMarshaller 349 | -> Bool 350 | -> TH.ExpQ 351 | generateHSCall vars hsArgMarshallers f hsResMarshaller inIO 352 | = invoke [hsArgMarshaller (varE var) | (var, hsArgMarshaller) <- zip vars hsArgMarshallers] 353 | f 354 | (if inIO then [| \call -> do { cresult <- call ; $(hsResMarshaller [|cresult|] [|return|]) } |] 355 | else [| \call -> do { let {cresult = call}; $(hsResMarshaller [|cresult|] [|return|]) } |]) 356 | where 357 | -- invoke [v1, .., vn] [a1, .., an] call r = [| a1 (\v1 -> .. -> an (\vn -> r (call v1 .. vn))..) |] 358 | invoke :: [TH.ExpQ -> TH.ExpQ] -> TH.ExpQ -> TH.ExpQ -> TH.ExpQ 359 | invoke [] call ret = [| $ret $call |] 360 | invoke (arg:args) call ret = arg [| \name -> $(invoke args [| $call name |] ret)|] 361 | 362 | -- |Emit the C file and return the foreign declarations. Needs to be the last use of an 'c...' function. 363 | -- (Just put it at the end of the Haskell module.) 364 | -- 365 | c_emit :: Q [TH.Dec] 366 | c_emit 367 | = do 368 | { loc <- location 369 | ; let origFname = loc_filename loc 370 | cFname = dropExtension origFname ++ "_c" 371 | cFname_h = cFname `addExtension` "h" 372 | cFname_m = cFname `addExtension` "c" 373 | ; headers <- getHeaders 374 | ; (c_h, c_m) <- getHoistedObjC 375 | ; runIO $ 376 | do 377 | { writeFile cFname_h (info origFname) 378 | ; appendFile cFname_h (unlines (map mkImport headers) ++ "\n") 379 | ; appendFile cFname_h (show $ QC.ppr c_h) 380 | ; writeFile cFname_m (info origFname) 381 | ; appendFile cFname_m ("#include \"HsFFI.h\"\n") 382 | ; appendFile cFname_m ("#include \"" ++ takeFileName cFname_h ++ "\"\n\n") 383 | ; appendFile cFname_m (show $ QC.ppr c_m) 384 | } 385 | ; c_jumptable <- getForeignTable 386 | ; labels <- getForeignLabels 387 | ; initialize <- [d|c_initialise :: IO () 388 | c_initialise 389 | = -- unsafePerformIO $ 390 | writeIORef $c_jumptable $ 391 | listArray ($(lift (1::Int)), $(lift $ length labels)) $ 392 | $(listE [ [|toDyn $(varE label)|] | label <- labels]) 393 | |] 394 | ; (initialize ++) <$> getHoistedHS 395 | } 396 | where 397 | mkImport h@('<':_) = "#include " ++ h ++ "" 398 | mkImport h = "#include \"" ++ h ++ "\"" 399 | 400 | info fname = "// Generated code: DO NOT EDIT\n\ 401 | \// generated from '" ++ fname ++ "'\n\ 402 | \// by package 'language-c-inline'\n\n" 403 | 404 | -- |Force type checking of all declaration appearing earlier in this module. 405 | -- 406 | -- Template Haskell performs type checking on declaration groups seperated by toplevel splices. In order for a type 407 | -- declaration to be available to an Objective-C inline directive, the type declaration must be in an earlier 408 | -- declaration group than the Objective-C inline directive. A toplevel Objective-C inline directive always is the start 409 | -- of a new declaration group; hence, it can be considered to be implicitly preceded by an 'c_typecheck'. 410 | -- 411 | c_typecheck :: Q [TH.Dec] 412 | c_typecheck = return [] 413 | -------------------------------------------------------------------------------- /Language/C/Inline/C/Hint.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, GADTs, TemplateHaskell, QuasiQuotes #-} 2 | 3 | -- | 4 | -- Module : Language.C.Inline.C.Hint 5 | -- Copyright : 2014 Manuel M T Chakravarty 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Manuel M T Chakravarty 9 | -- Stability : experimental 10 | -- Portability : non-portable (GHC extensions) 11 | -- 12 | -- This module provides Objective-C specific hints. 13 | 14 | module Language.C.Inline.C.Hint ( 15 | -- * Class hints 16 | Class(..), IsType 17 | ) where 18 | 19 | -- standard libraries 20 | import Language.Haskell.TH as TH 21 | 22 | -- quasi-quotation libraries 23 | import Language.C.Quote as QC 24 | import Language.C.Quote.C as QC 25 | 26 | -- friends 27 | import Language.C.Inline.Error 28 | import Language.C.Inline.Hint 29 | import Language.C.Inline.TH 30 | 31 | 32 | -- |Class of entities that can be used as TH types. 33 | -- 34 | class IsType ty where 35 | theType :: ty -> Q TH.Type 36 | 37 | instance IsType TH.Type where 38 | theType = return 39 | 40 | instance IsType (Q TH.Type) where 41 | theType = id 42 | 43 | instance IsType TH.Name where 44 | theType name 45 | = do 46 | { info <- reify name 47 | ; case info of 48 | TyConI _ -> return $ ConT name 49 | PrimTyConI _ _ _ -> return $ ConT name 50 | FamilyI _ _ -> return $ ConT name 51 | _ -> 52 | do 53 | { reportErrorAndFail QC.C11 $ 54 | "expected '" ++ show name ++ "' to be a type name, but it is " ++ 55 | show (TH.ppr info) 56 | } 57 | } 58 | 59 | -- |Hint indicating to marshal an Objective-C object as a foreign pointer, where the argument is the Haskell type 60 | -- representing the Objective-C class. The Haskell type name must coincide with the Objective-C class name. 61 | -- 62 | data Class where 63 | Class :: IsType t => t -> Class 64 | 65 | instance Hint Class where 66 | haskellType (Class tyish) 67 | = do 68 | { ty <- theType tyish 69 | ; _ <- foreignWrapperDatacon ty -- FAILS if the declaration is not a 'ForeignPtr' wrapper 70 | ; return ty 71 | } 72 | foreignType (Class tyish) 73 | = do 74 | { name <- theType tyish >>= headTyConNameOrError QC.C11 75 | ; return $ Just [cty| typename $id:(nameBase name) * |] 76 | } 77 | showQ (Class tyish) 78 | = do 79 | { ty <- theType tyish 80 | ; return $ "Class " ++ show ty 81 | } 82 | -------------------------------------------------------------------------------- /Language/C/Inline/C/Marshal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternGuards, TemplateHaskell, QuasiQuotes #-} 2 | 3 | -- | 4 | -- Module : Language.C.Inline.C.Marshal 5 | -- Copyright : [2013] Manuel M T Chakravarty 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Manuel M T Chakravarty 9 | -- Stability : experimental 10 | -- Portability : non-portable (GHC extensions) 11 | -- 12 | -- C-specific marshalling functions. 13 | -- 14 | -- FIXME: Some of the code can go into a module for general marshalling, as only some of it is C-specific. 15 | 16 | module Language.C.Inline.C.Marshal ( 17 | -- * Determine corresponding foreign types of Haskell types 18 | haskellTypeToCType, 19 | 20 | -- * Marshaller types 21 | HaskellMarshaller, CMarshaller, 22 | 23 | -- * Compute bridging types and marshallers 24 | generateHaskellToCMarshaller, generateCToHaskellMarshaller 25 | ) where 26 | 27 | -- common libraries 28 | import Data.Map as Map 29 | import Data.Word 30 | import Foreign.C as C 31 | import Foreign.Marshal as C 32 | import Foreign.Ptr as C 33 | import Foreign.ForeignPtr as C 34 | import Foreign.StablePtr as C 35 | import Language.Haskell.TH as TH 36 | 37 | -- quasi-quotation libraries 38 | import Language.C.Quote as QC 39 | import Language.C.Quote.C as QC 40 | 41 | -- friends 42 | import Language.C.Inline.Error 43 | import Language.C.Inline.State 44 | import Language.C.Inline.TH 45 | 46 | 47 | -- Determine foreign types 48 | -- ----------------------- 49 | 50 | -- |Determine the C type that we map a given Haskell type to. 51 | -- 52 | haskellTypeToCType :: QC.Extensions -> TH.Type -> Q (Maybe QC.Type) 53 | haskellTypeToCType lang (ForallT _tvs _ctxt ty) -- ignore quantifiers and contexts 54 | = haskellTypeToCType lang ty 55 | haskellTypeToCType lang ty 56 | = do 57 | { maybe_marshaller <- lookupMarshaller ty 58 | ; case maybe_marshaller of 59 | Just (_, _, cTy, _, _) -> return $ Just cTy -- use a custom marshaller if one is available for this type 60 | Nothing -> haskellTypeToCType' lang ty -- otherwise, continue below... 61 | } 62 | where 63 | haskellTypeToCType' lang' (ListT `AppT` (ConT ch)) -- marshal '[Char]' as 'String' 64 | | ch == ''Char 65 | = haskellTypeNameToCType lang' ''String 66 | haskellTypeToCType' lang' ty'@(ConT maybeC `AppT` argTy) -- encode a 'Maybe' around a pointer type in the pointer 67 | | maybeC == ''Maybe 68 | = do 69 | { cargTy <- haskellTypeToCType lang' argTy 70 | ; if fmap isCPtrType cargTy == Just True 71 | then 72 | return cargTy 73 | else 74 | unknownType lang' ty' 75 | } 76 | haskellTypeToCType' lang' (ConT tc) -- nullary type constructors are delegated 77 | = haskellTypeNameToCType lang' tc 78 | haskellTypeToCType' lang' ty'@(VarT _) -- can't marshal an unknown type 79 | = unknownType lang' ty' 80 | haskellTypeToCType' lang' ty'@(UnboxedTupleT _) -- there is nothing like unboxed tuples in C 81 | = unknownType lang' ty' 82 | haskellTypeToCType' _lang _ty -- everything else is marshalled as a stable pointer 83 | = return $ Just [cty| typename HsStablePtr |] 84 | 85 | unknownType lang' _ty 86 | = do 87 | { reportErrorWithLang lang' $ "don't know a foreign type suitable for Haskell type '" ++ TH.pprint ty ++ "'" 88 | ; return Nothing 89 | } 90 | 91 | -- |Determine the C type that we map a given Haskell type constructor to — i.e., we map all Haskell types 92 | -- whose outermost constructor is the given type constructor to the returned C type. 93 | -- 94 | -- All types representing boxed values that are not explicitly mapped to a specific C type, are mapped to 95 | -- stable pointers. 96 | -- 97 | haskellTypeNameToCType :: QC.Extensions -> TH.Name -> Q (Maybe QC.Type) 98 | haskellTypeNameToCType ext tyname 99 | = case Map.lookup tyname (haskellToCTypeMap ext) of 100 | Just cty' -> return $ Just cty' 101 | Nothing -> do 102 | { info <- reify tyname 103 | ; case info of 104 | PrimTyConI _ _ True -> unknownUnboxedType 105 | _ -> return $ Just [cty| typename HsStablePtr |] 106 | } 107 | where 108 | unknownUnboxedType = do 109 | { reportErrorWithLang ext $ 110 | "don't know a foreign type suitable for the unboxed Haskell type '" ++ show tyname ++ "'" 111 | ; return Nothing 112 | } 113 | 114 | haskellToCTypeMap :: QC.Extensions -> Map TH.Name QC.Type 115 | haskellToCTypeMap C11 116 | = Map.fromList 117 | [ (''CChar, [cty| char |]) 118 | , (''CSChar, [cty| signed char |]) 119 | , (''CUChar, [cty| unsigned char |]) 120 | , (''CShort, [cty| short |]) 121 | , (''CUShort, [cty| unsigned short |]) 122 | , (''Int, [cty| int |]) 123 | , (''CInt, [cty| int |]) 124 | , (''Word, [cty| unsigned int |]) 125 | , (''CUInt, [cty| unsigned int |]) 126 | , (''CLong, [cty| long |]) 127 | , (''CULong, [cty| unsigned long |]) 128 | , (''CLLong, [cty| long long |]) 129 | , (''CULLong, [cty| unsigned long long |]) 130 | -- 131 | , (''Float, [cty| float |]) 132 | , (''CFloat, [cty| float |]) 133 | , (''Double, [cty| double |]) 134 | , (''CDouble, [cty| double |]) 135 | -- 136 | , (''Bool, [cty| typename BOOL |]) 137 | , (''String, [cty| const char * |]) 138 | , (''(), [cty| void |]) 139 | ] 140 | haskellToCTypeMap _lang 141 | = Map.empty 142 | 143 | -- Check whether the given C type is an overt pointer. 144 | -- 145 | isCPtrType :: QC.Type -> Bool 146 | isCPtrType (Type _ (Ptr {}) _) = True 147 | isCPtrType (Type _ (BlockPtr {}) _) = True 148 | isCPtrType (Type _ (Array {}) _) = True 149 | isCPtrType ty 150 | | ty == [cty| typename HsStablePtr |] = True 151 | | otherwise = False 152 | 153 | 154 | -- Determine marshallers and their bridging types 155 | -- ---------------------------------------------- 156 | 157 | -- |Constructs Haskell code to marshal a value (used to marshal arguments and results). 158 | -- 159 | -- * The first argument is the code referring to the value to be marshalled. 160 | -- * The second argument is the continuation that gets the marshalled value as an argument. 161 | -- 162 | type HaskellMarshaller = TH.ExpQ -> TH.ExpQ -> TH.ExpQ 163 | 164 | -- |Constructs C code to marshal an argument (used to marshal arguments and results). 165 | -- 166 | -- * The argument is the identifier of the value to be marshalled. 167 | -- * The result of the generated expression is the marshalled value. 168 | -- 169 | type CMarshaller = TH.Name -> QC.Exp 170 | 171 | -- |Generate the type-specific marshalling code for Haskell to C land marshalling for a Haskell-C type pair. 172 | -- 173 | -- The result has the following components: 174 | -- 175 | -- * Haskell type after Haskell-side marshalling. 176 | -- * C type before C-side marshalling. 177 | -- * Generator for the Haskell-side marshalling code. 178 | -- * Generator for the C-side marshalling code. 179 | -- 180 | generateHaskellToCMarshaller :: TH.Type -> QC.Type -> Q (TH.TypeQ, QC.Type, HaskellMarshaller, CMarshaller) 181 | generateHaskellToCMarshaller hsTy cTy@(Type (DeclSpec _ _ (Tnamed (Id name _) _ _) _) (Ptr _ (DeclRoot _) _) _) 182 | | Just name == maybeHeadName -- wrapped ForeignPtr mapped to an Objective-C class 183 | = return ( ptrOfForeignPtrWrapper hsTy 184 | , cTy 185 | , \val cont -> [| C.withForeignPtr ($(unwrapForeignPtrWrapper hsTy) $val) $cont |] 186 | , \argName -> [cexp| $id:(show argName) |] 187 | ) 188 | | otherwise 189 | = do 190 | { maybe_marshaller <- lookupMarshaller hsTy 191 | ; case maybe_marshaller of 192 | Just (_, classTy, cTy', haskellToC, _cToHaskell) 193 | | cTy' == cTy -- custom marshaller mapping to an Objective-C class 194 | -> return ( ptrOfForeignPtrWrapper classTy 195 | , cTy 196 | , \val cont -> [| do 197 | { nsClass <- $(varE haskellToC) $val 198 | ; C.withForeignPtr ($(unwrapForeignPtrWrapper classTy) nsClass) $cont 199 | } |] 200 | , \argName -> [cexp| $id:(show argName) |] 201 | ) 202 | Nothing -- other => continue below 203 | -> generateHaskellToCMarshaller' hsTy cTy 204 | } 205 | where 206 | maybeHeadName = fmap nameBase $ headTyConName hsTy 207 | generateHaskellToCMarshaller hsTy cTy = generateHaskellToCMarshaller' hsTy cTy 208 | 209 | generateHaskellToCMarshaller' :: TH.Type -> QC.Type -> Q (TH.TypeQ, QC.Type, HaskellMarshaller, CMarshaller) 210 | generateHaskellToCMarshaller' hsTy@(ConT mbe `AppT` argTy) cTy 211 | | mbe == ''Maybe && isCPtrType cTy 212 | = do 213 | { (argTy', cTy', hsMarsh, cMarsh) <- generateHaskellToCMarshaller argTy cTy 214 | ; ty <- argTy' 215 | ; resolve ty argTy' cTy' hsMarsh cMarsh 216 | } 217 | where 218 | resolve ty argTy' cTy' hsMarsh cMarsh 219 | = case ty of 220 | ConT ptr `AppT` _ 221 | | ptr == ''C.Ptr -> return ( argTy' 222 | , cTy' 223 | , \val cont -> [| case $val of 224 | Nothing -> $cont C.nullPtr 225 | Just val' -> $(hsMarsh [|val'|] cont) |] 226 | , cMarsh 227 | ) 228 | | ptr == ''C.StablePtr -> return ( argTy' 229 | , cTy' 230 | , \val cont -> [| case $val of 231 | Nothing -> $cont (C.castPtrToStablePtr C.nullPtr) 232 | Just val' -> $(hsMarsh [|val'|] cont) |] 233 | -- NB: the above cast works for GHC, but is in the grey area 234 | -- of the FFI spec 235 | , cMarsh 236 | ) 237 | ConT con 238 | -> do 239 | { info <- reify con 240 | ; case info of 241 | TyConI (TySynD _name [] tysyn) -> resolve tysyn argTy' cTy' hsMarsh cMarsh 242 | -- chase type synonyms (only nullary ones at the moment) 243 | _ -> missingErr 244 | } 245 | _ -> missingErr 246 | missingErr = reportErrorAndFail C11 $ 247 | "missing 'Maybe' marshalling for '" ++ prettyQC cTy ++ "' to '" ++ TH.pprint hsTy ++ "'" 248 | generateHaskellToCMarshaller' hsTy cTy 249 | | Just hsMarshalTy <- Map.lookup cTy cIntegralMap -- checking whether it is an integral type 250 | = return ( hsMarshalTy 251 | , cTy 252 | , \val cont -> [| $cont (fromIntegral $val) |] 253 | , \argName -> [cexp| $id:(show argName) |] 254 | ) 255 | | Just hsMarshalTy <- Map.lookup cTy cFloatingMap -- checking whether it is a floating type 256 | = return ( hsMarshalTy 257 | , cTy 258 | , \val cont -> [| $cont (realToFrac $val) |] 259 | , \argName -> [cexp| $id:(show argName) |] 260 | ) 261 | | cTy == [cty| typename BOOL |] 262 | = return ( [t| C.CSChar |] 263 | , cTy 264 | , \val cont -> [| $cont (C.fromBool $val) |] 265 | , \argName -> [cexp| ($id:(show argName)) |] 266 | ) 267 | 268 | | cTy == [cty| const char * |] 269 | = return ( [t| C.CString |] 270 | , [cty| const char * |] 271 | , \val cont -> [| C.withCString $val $cont |] 272 | , \argName -> [cexp| ($id:(show argName)) |] 273 | ) 274 | 275 | | cTy == [cty| typename HsStablePtr |] 276 | = return ( [t| C.StablePtr $(return hsTy) |] 277 | , cTy 278 | , \val cont -> [| do { C.newStablePtr $val >>= $cont } |] 279 | , \argName -> [cexp| $id:(show argName) |] 280 | ) 281 | | otherwise 282 | = reportErrorAndFail C11 $ "cannot marshal '" ++ TH.pprint hsTy ++ "' to '" ++ prettyQC cTy ++ "'" 283 | 284 | -- |Generate the type-specific marshalling code for Haskell to C land marshalling for a C-Haskell type pair. 285 | -- 286 | -- The result has the following components: 287 | -- 288 | -- * Haskell type after Haskell-side marshalling. 289 | -- * C type before C-side marshalling. 290 | -- * Generator for the Haskell-side marshalling code. 291 | -- * Generator for the C-side marshalling code. 292 | -- 293 | generateCToHaskellMarshaller :: TH.Type -> QC.Type -> Q (TH.TypeQ, QC.Type, HaskellMarshaller, CMarshaller) 294 | generateCToHaskellMarshaller hsTy cTy@(Type (DeclSpec _ _ (Tnamed (Id name _) _ _) _) (Ptr _ (DeclRoot _) _) _) 295 | | Just name == maybeHeadName -- ForeignPtr mapped to an Objective-C class 296 | = return ( ptrOfForeignPtrWrapper hsTy 297 | , cTy 298 | , \val cont -> do { let datacon = foreignWrapperDatacon hsTy 299 | ; [| do { fptr <- newForeignPtr_ $val; $cont ($datacon fptr) } |] 300 | } 301 | , \argName -> [cexp| $id:(show argName) |] 302 | ) 303 | | otherwise 304 | = do 305 | { maybe_marshaller <- lookupMarshaller hsTy 306 | ; case maybe_marshaller of 307 | Just (_, classTy, cTy', _haskellToC, cToHaskell) 308 | | cTy' == cTy -- custom marshaller mapping to an Objective-C class 309 | -> return ( ptrOfForeignPtrWrapper classTy 310 | , cTy 311 | , \val cont -> do { let datacon = foreignWrapperDatacon classTy 312 | ; [| do 313 | { fptr <- newForeignPtr_ $val 314 | ; hsVal <- $(varE cToHaskell) ($datacon fptr) 315 | ; $cont hsVal 316 | } |] 317 | } 318 | , \argName -> [cexp| $id:(show argName) |] 319 | ) 320 | Nothing -- other => continue below 321 | -> generateCToHaskellMarshaller' hsTy cTy 322 | } 323 | where 324 | maybeHeadName = fmap nameBase $ headTyConName hsTy 325 | generateCToHaskellMarshaller hsTy cTy = generateCToHaskellMarshaller' hsTy cTy 326 | 327 | generateCToHaskellMarshaller' :: TH.Type -> QC.Type -> Q (TH.TypeQ, QC.Type, HaskellMarshaller, CMarshaller) 328 | generateCToHaskellMarshaller' hsTy@(ConT mbe `AppT` argTy) cTy 329 | | mbe == ''Maybe && isCPtrType cTy 330 | = do 331 | { (argTy', cTy', hsMarsh, cMarsh) <- generateCToHaskellMarshaller argTy cTy 332 | ; ty <- argTy' 333 | ; resolve ty argTy' cTy' hsMarsh cMarsh 334 | } 335 | where 336 | resolve ty argTy' cTy' hsMarsh cMarsh 337 | = case ty of 338 | ConT ptr `AppT` _ 339 | | ptr == ''C.Ptr -> return ( argTy' 340 | , cTy' 341 | , \val cont -> [| if $val == C.nullPtr 342 | then $cont Nothing 343 | else $(hsMarsh val [| $cont . Just |]) |] 344 | , cMarsh 345 | ) 346 | | ptr == ''C.StablePtr -> return ( argTy' 347 | , cTy' 348 | , \val cont -> [| if (C.castStablePtrToPtr $val) == C.nullPtr 349 | then $cont Nothing 350 | else $(hsMarsh val [| $cont . Just |]) |] 351 | -- NB: the above cast works for GHC, but is in the grey area 352 | -- of the FFI spec 353 | , cMarsh 354 | ) 355 | ConT con 356 | -> do 357 | { info <- reify con 358 | ; case info of 359 | TyConI (TySynD _name [] tysyn) -> resolve tysyn argTy' cTy' hsMarsh cMarsh 360 | -- chase type synonyms (only nullary ones at the moment) 361 | _ -> missingErr 362 | } 363 | _ -> missingErr 364 | missingErr = reportErrorAndFail C11 $ 365 | "missing 'Maybe' marshalling for '" ++ prettyQC cTy ++ "' to '" ++ TH.pprint hsTy ++ "'" 366 | generateCToHaskellMarshaller' hsTy cTy 367 | | Just hsMarshalTy <- Map.lookup cTy cIntegralMap -- checking whether it is an integral type 368 | = return ( hsMarshalTy 369 | , cTy 370 | , \val cont -> [| $cont (fromIntegral $val) |] 371 | , \argName -> [cexp| $id:(show argName) |] 372 | ) 373 | | Just hsMarshalTy <- Map.lookup cTy cFloatingMap -- checking whether it is a floating type 374 | = return ( hsMarshalTy 375 | , cTy 376 | , \val cont -> [| $cont (realToFrac $val) |] 377 | , \argName -> [cexp| $id:(show argName) |] 378 | ) 379 | | cTy == [cty| typename BOOL |] 380 | = return ( [t| C.CSChar |] 381 | , cTy 382 | , \val cont -> [| $cont (C.toBool $val) |] 383 | , \argName -> [cexp| $id:(show argName) |] 384 | ) 385 | 386 | {- 387 | | cTy == [cty| typename CString * |] 388 | = return ( [t| C.CString |] 389 | , [cty| char * |] 390 | , \val cont -> [| do { str <- C.peekCString $val; C.free $val; $cont str } |] 391 | , \argName -> 392 | let arg = show argName 393 | in 394 | [cexp| 395 | ( $id:arg ) 396 | ? ({ typename NSUInteger maxLen = [$id:arg maximumLengthOfBytesUsingEncoding:NSUTF8StringEncoding] + 1; 397 | char *buffer = malloc (maxLen); 398 | if (![$id:arg getCString:buffer maxLength:maxLen encoding:NSUTF8StringEncoding]) 399 | *buffer = '\0'; 400 | buffer; 401 | }) 402 | : nil 403 | |] 404 | ) 405 | -} 406 | | cTy == [cty| const char * |] 407 | = return ( [t| C.CString |] 408 | , [cty| const char * |] 409 | 410 | -- , \val cont -> [| C.withCString $val $cont |] 411 | 412 | , \val cont -> [| C.peekCString $val >>= $cont |] 413 | 414 | , \argName -> [cexp| ($id:(show argName)) |] 415 | ) 416 | 417 | 418 | 419 | | cTy == [cty| typename HsStablePtr |] 420 | = return ( [t| C.StablePtr $(return hsTy) |] 421 | , cTy 422 | , \val cont -> [| do { C.deRefStablePtr $val >>= $cont } |] 423 | , \argName -> [cexp| $id:(show argName) |] 424 | ) 425 | | cTy == [cty| void |] 426 | = return ( [t| () |] 427 | , [cty| void |] 428 | , \val cont -> [| $cont $val |] 429 | , \argName -> [cexp| $id:(show argName) |] 430 | ) 431 | | otherwise 432 | = reportErrorAndFail C11 $ "cannot marshall '" ++ prettyQC cTy ++ "' to '" ++ TH.pprint hsTy ++ "'" 433 | 434 | 435 | cIntegralMap :: Map QC.Type TypeQ 436 | cIntegralMap = Map.fromList 437 | [ ([cty| char |], [t| C.CChar |]) 438 | , ([cty| signed char |], [t| C.CChar |]) 439 | , ([cty| unsigned char |], [t| C.CUChar |]) 440 | , ([cty| short |], [t| C.CShort |]) 441 | , ([cty| unsigned short |], [t| C.CUShort |]) 442 | , ([cty| int |], [t| C.CInt |]) 443 | , ([cty| unsigned int |], [t| C.CUInt |]) 444 | , ([cty| long |], [t| C.CLong |]) 445 | , ([cty| unsigned long |], [t| C.CULong |]) 446 | , ([cty| long long |], [t| C.CLLong |]) 447 | , ([cty| unsigned long long |], [t| C.CULLong |]) 448 | ] 449 | 450 | cFloatingMap :: Map QC.Type TypeQ 451 | cFloatingMap = Map.fromList 452 | [ ([cty| float |] , [t| C.CFloat |]) 453 | , ([cty| double |], [t| C.CDouble |]) 454 | ] 455 | -------------------------------------------------------------------------------- /Language/C/Inline/Error.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, QuasiQuotes #-} 2 | 3 | -- | 4 | -- Module : Language.C.Inline.Error 5 | -- Copyright : [2013] Manuel M T Chakravarty 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Manuel M T Chakravarty 9 | -- Stability : experimental 10 | -- Portability : non-portable (GHC extensions) 11 | -- 12 | -- This module provides support for error reporting. 13 | 14 | module Language.C.Inline.Error ( 15 | -- * Error reporting 16 | reportErrorWithLang, reportErrorAndFail, 17 | 18 | -- * Exception handling 19 | tryWithPlaceholder, 20 | 21 | -- * Pretty printing for error messages 22 | prettyQC 23 | ) where 24 | 25 | import Language.Haskell.TH as TH 26 | 27 | -- quasi-quotation libraries 28 | import Language.C.Quote as QC 29 | import Text.PrettyPrint.Mainland as QC 30 | 31 | 32 | reportErrorWithLang :: QC.Extensions -> String -> Q () 33 | reportErrorWithLang lang msg 34 | = do 35 | { _loc <- location 36 | -- FIXME: define a Show instance for 'Loc' and use it to prefix position to error 37 | ; TH.reportError $ "Inline " ++ showLang lang ++ ": " ++ msg 38 | } 39 | 40 | reportErrorAndFail :: QC.Extensions -> String -> Q a 41 | reportErrorAndFail lang msg 42 | = reportErrorAndFail' $ "Inline " ++ showLang lang ++ ": " ++ msg 43 | 44 | reportErrorAndFail' :: String -> Q a 45 | reportErrorAndFail' msg 46 | = do 47 | { TH.reportError msg 48 | ; fail "Fatal error due to inline code" 49 | } 50 | 51 | -- reportErrorAndBail :: String -> Q TH.Exp 52 | -- reportErrorAndBail msg 53 | -- = do 54 | -- { reportError msg 55 | -- ; Just undefinedName <- TH.lookupValueName "Prelude.undefined" 56 | -- ; return $ VarE undefinedName 57 | -- } 58 | 59 | showLang :: QC.Extensions -> String 60 | showLang QC.Antiquotation = "C" 61 | showLang QC.C11 = "C 11" 62 | showLang QC.Gcc = "GCC C" 63 | showLang QC.CUDA = "CUDA C" 64 | showLang QC.OpenCL = "OpenCL" 65 | showLang QC.ObjC = "Objective-C" 66 | 67 | -- If the tried computation fails, insert a placeholder expression. 68 | -- 69 | -- We report all errors explicitly. Failing would just duplicate errors. 70 | -- 71 | tryWithPlaceholder :: Q TH.Exp -> Q TH.Exp 72 | tryWithPlaceholder = ([| error "language-c-quote: internal error: tryWithPlaceholder" |] `recover`) 73 | 74 | prettyQC :: QC.Pretty a => a -> String 75 | prettyQC = QC.pretty 80 . QC.ppr 76 | -------------------------------------------------------------------------------- /Language/C/Inline/Hint.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, GADTs, FlexibleInstances #-} 2 | 3 | -- | 4 | -- Module : Language.C.Inline.Hint 5 | -- Copyright : [2013..2014] Manuel M T Chakravarty 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Manuel M T Chakravarty 9 | -- Stability : experimental 10 | -- Portability : non-portable (GHC extensions) 11 | -- 12 | -- This module provides the definition of marshalling hints. 13 | 14 | module Language.C.Inline.Hint ( 15 | -- * Annotations 16 | Annotated(..), (<:), void, annotatedShowQ, 17 | 18 | -- * Hints 19 | Hint(..), 20 | 21 | -- * Querying of annotated entities 22 | haskellTypeOf, foreignTypeOf, stripAnnotation 23 | ) where 24 | 25 | -- common libraries 26 | import Control.Applicative 27 | import Language.Haskell.TH as TH 28 | 29 | -- quasi-quotation libraries 30 | import Language.C.Quote as QC 31 | 32 | -- friends 33 | import Language.C.Inline.Error 34 | 35 | 36 | -- |Annotating entities with hints. 37 | -- 38 | -- The alternatives are to provide an explicit marshalling hint with '(:>)', or to leave the marshalling 39 | -- implicitly defined by the name's type. 40 | -- 41 | data Annotated e where 42 | (:>) :: Hint hint => e -> hint -> Annotated e -- explicit marshalling hint 43 | Typed :: Name -> Annotated Name -- marshalling implicitly defined by name's type 44 | 45 | -- |We provide additional syntax where the hint is to the left of the annotated entity. 46 | -- 47 | (<:) :: Hint hint => hint -> e -> Annotated e 48 | (<:) = flip (:>) 49 | 50 | -- |Annotation for irrelevant results 51 | -- 52 | void :: e -> Annotated e 53 | void = (''() <:) 54 | 55 | -- |Pretty print an annotated entity. 56 | -- 57 | annotatedShowQ :: Show e => Annotated e -> Q String 58 | annotatedShowQ (e :> hint) = ((show e ++ " :> ") ++) <$> showQ hint 59 | annotatedShowQ (Typed name) = return $ "Typed " ++ show name 60 | 61 | -- |Hints imply marshalling strategies, which include source and destination types for marshalling. 62 | -- 63 | class Hint hint where 64 | haskellType :: hint -> Q TH.Type 65 | foreignType :: hint -> Q (Maybe QC.Type) -- ^In case of 'Nothing', the foreign type is determined by the Haskell type. 66 | showQ :: hint -> Q String 67 | 68 | instance Hint Name where -- must be a type name 69 | haskellType = conT 70 | foreignType = const (return Nothing) 71 | showQ = return . show 72 | 73 | instance Hint (Q TH.Type) where 74 | haskellType = id 75 | foreignType = const (return Nothing) 76 | showQ = (show <$>) 77 | 78 | -- |Determine the Haskell type implied for the given annotated entity. 79 | -- 80 | haskellTypeOf :: Annotated e -> Q TH.Type 81 | haskellTypeOf (_ :> hint) = haskellType hint 82 | haskellTypeOf (Typed name) 83 | = do 84 | { info <- reify name 85 | ; case info of 86 | ClassOpI _ ty _ _ -> return ty 87 | VarI _ ty _ _ -> return ty 88 | nonVarInfo -> 89 | do 90 | { reportErrorAndFail QC.C11 $ 91 | "expected '" ++ show name ++ "' to be a typed variable name, but it is " ++ 92 | show (TH.ppr nonVarInfo) 93 | } 94 | } 95 | 96 | -- |Determine the foreign type *directly* implied for the given annotated entity if any. 97 | -- 98 | foreignTypeOf :: Annotated e -> Q (Maybe QC.Type) 99 | foreignTypeOf (_ :> hint) = foreignType hint 100 | foreignTypeOf (Typed _) = return Nothing 101 | 102 | -- |Remove the annotation. 103 | -- 104 | stripAnnotation :: Annotated e -> e 105 | stripAnnotation (e :> _) = e 106 | stripAnnotation (Typed name) = name 107 | -------------------------------------------------------------------------------- /Language/C/Inline/ObjC.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, QuasiQuotes #-} 2 | 3 | -- | 4 | -- Module : Language.C.Inline.ObjC 5 | -- Copyright : [2013] Manuel M T Chakravarty 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Manuel M T Chakravarty 9 | -- Stability : experimental 10 | -- Portability : non-portable (GHC extensions) 11 | -- 12 | -- This module exports the principal API for inline Objective-C. 13 | 14 | module Language.C.Inline.ObjC ( 15 | 16 | -- * Re-export types from 'Foreign.C' 17 | module Foreign.C.Types, CString, CStringLen, CWString, CWStringLen, Errno, ForeignPtr, castForeignPtr, 18 | 19 | -- * Re-export types from Template Haskell 20 | Name, 21 | 22 | -- * Combinators for inline Objective-C 23 | objc_import, objc_interface, objc_implementation, objc_record, objc_marshaller, objc_typecheck, objc, objc_emit, 24 | 25 | -- * Marshalling annotations 26 | Annotated(..), (<:), void, Class(..), IsType, 27 | 28 | -- * Property maps 29 | PropertyAccess, (==>), (-->) 30 | ) where 31 | 32 | -- common libraries 33 | import Control.Applicative 34 | import Control.Monad hiding (void) 35 | import Data.Array 36 | import Data.Char 37 | import Data.Dynamic 38 | import Data.IORef 39 | import Data.List 40 | import Data.Maybe 41 | import Foreign.C as C 42 | import Foreign.C.Types 43 | import Foreign.ForeignPtr as C 44 | import Language.Haskell.TH as TH 45 | import Language.Haskell.TH.Syntax as TH 46 | import System.FilePath 47 | import System.IO.Unsafe (unsafePerformIO) 48 | 49 | -- quasi-quotation libraries 50 | import Language.C.Quote as QC 51 | import Language.C.Quote.ObjC as QC 52 | import Text.PrettyPrint.Mainland as QC 53 | 54 | -- friends 55 | import Language.C.Inline.Error 56 | import Language.C.Inline.Hint 57 | import Language.C.Inline.State 58 | import Language.C.Inline.TH 59 | import Language.C.Inline.ObjC.Hint 60 | import Language.C.Inline.ObjC.Marshal 61 | 62 | 63 | -- |Specify imported Objective-C files. Needs to be spliced where an import declaration can appear. (Just put it 64 | -- straight after all the import statements in the module.) 65 | -- 66 | -- FIXME: need to use TH.addDependentFile on each of the imported ObjC files & read headers 67 | -- 68 | objc_import :: [FilePath] -> Q [TH.Dec] 69 | objc_import headers 70 | = do 71 | { mapM_ stashHeader headers 72 | ; objc_jumptable <- newName "objc_jumptable" 73 | ; setForeignTable $ varE objc_jumptable 74 | ; sequence $ [ sigD objc_jumptable [t|IORef (Array Int Dynamic)|] 75 | , pragInlD objc_jumptable NoInline FunLike AllPhases -- reqs template-haskell 2.8.0.0 76 | -- , pragInlD objc_jumptable (inlineSpecNoPhase False False) 77 | , valD (varP objc_jumptable) (normalB [|unsafePerformIO $ newIORef (array (0, 0) [])|]) [] 78 | ] 79 | -- ; return $ [d|import Language.C.Quote as ObjC; 80 | -- import Language.C.Quote.ObjC as ObjC; 81 | -- import Foreign.C as C 82 | -- |] 83 | } 84 | -- FIXME: Should this also add the Language.C.Quote imports? (We might not need to generate any imports at all?!?) 85 | 86 | -- |Inline Objective-C top-level definitions for a header file ('.h'). 87 | -- 88 | objc_interface :: [QC.Definition] -> Q [TH.Dec] 89 | objc_interface defs 90 | = do 91 | { stashObjC_h defs 92 | ; return [] 93 | } 94 | 95 | -- |Inline Objective-C top-level definitions for an implementation file ('.m'). 96 | -- 97 | -- The top-level Haskell variables given in the first argument will be foreign exported to be accessed from the 98 | -- generated Objective-C code. In C, these Haskell variables will always be represented as functions. (In particular, if 99 | -- the Haskell variable refers to a CAF, it will be a nullary function in C — after all, a thunk may still need to be 100 | -- evaluated.) 101 | -- 102 | objc_implementation :: [Annotated TH.Name] -> [QC.Definition] -> Q [TH.Dec] 103 | objc_implementation ann_vars defs 104 | = do 105 | { mapM_ exportVar ann_vars 106 | ; stashObjC_m defs 107 | ; return [] 108 | } 109 | where 110 | exportVar ann_var 111 | = do 112 | { -- Determine the argument and result types of the exported Haskell function 113 | ; let var = stripAnnotation ann_var 114 | ; (tvs, argTys, inIO, resTy) <- splitHaskellType <$> haskellTypeOf ann_var 115 | 116 | -- Determine C types 117 | ; maybe_cArgTys <- mapM (haskellTypeToCType ObjC) argTys 118 | ; maybe_cResTy <- haskellTypeToCType ObjC resTy 119 | ; let cannotMapAllTypes = Nothing `elem` (maybe_cResTy : maybe_cArgTys) 120 | cArgTys = map maybeErrorCtype maybe_cArgTys 121 | cResTy = maybeErrorCtype maybe_cResTy 122 | 123 | ; if cannotMapAllTypes 124 | then do {str <- annotatedShowQ ann_var; reportErrorWithLang ObjC $ "invalid marshalling: " ++ str} 125 | else do 126 | 127 | { -- Determine the bridging type and the marshalling code 128 | ; (bridgeArgTys, cBridgeArgTys, hsArgMarshallers, cArgMarshallers) <- 129 | unzip4 <$> zipWithM generateCToHaskellMarshaller argTys cArgTys 130 | ; (bridgeResTy, cBridgeResTy, hsResMarshaller, cResMarshaller) <- generateHaskellToCMarshaller resTy cResTy 131 | 132 | -- Haskell type of the foreign wrapper function 133 | ; let hsWrapperTy = haskellWrapperType tvs bridgeArgTys bridgeResTy 134 | 135 | -- Generate the Haskell wrapper 136 | ; let cwrapperName = mkName . nameBase $ var 137 | ; hswrapperName <- newName (nameBase var ++ "_hswrapper") 138 | ; hsArgVars <- mapM (const $ newName "arg") bridgeArgTys 139 | ; stashHS 140 | [ forExpD CCall (show hswrapperName) hswrapperName hsWrapperTy 141 | , sigD hswrapperName hsWrapperTy 142 | , funD hswrapperName 143 | [ clause (map varP hsArgVars) 144 | (normalB $ generateHSCall hsArgVars hsArgMarshallers (varE var) hsResMarshaller inIO) 145 | [] 146 | ] 147 | ] 148 | 149 | -- Generate the C wrapper code (both prototype and definition) 150 | ; cArgVars <- mapM (\n -> newName $ "arg" ++ show n) [1..length cBridgeArgTys] 151 | ; let cArgVarExps = [ [cexp| $id:(nameBase var') |] | var' <- cArgVars] 152 | call = [cexp| $id:(show hswrapperName) ( $args:cArgVarExps ) |] 153 | (_wrapperProto, wrapperDef) 154 | = generateCWrapper cwrapperName cBridgeArgTys cArgVars cArgMarshallers cArgTys cArgVars 155 | call 156 | resTy cBridgeResTy cResMarshaller cResTy 157 | ; stashObjC_m $ 158 | -- C prototype of the foreign exported Haskell-side wrapper 159 | [cunit| 160 | $ty:cBridgeResTy $id:(show hswrapperName) ($params:(cParams cBridgeArgTys cArgVars)); 161 | |] 162 | ++ 163 | map makeStaticFunc wrapperDef 164 | } } 165 | 166 | splitHaskellType (ForallT tvs _ctxt ty) -- collect quantified variables (drop the context) 167 | = let (tvs', args, inIO, res) = splitHaskellType ty 168 | in 169 | (tvs ++ tvs', args, inIO, res) 170 | splitHaskellType (ArrowT `AppT` arg `AppT` res) -- collect argument types 171 | = let (tvs, args, inIO, res') = splitHaskellType res 172 | in 173 | (tvs, arg:args, inIO, res') 174 | splitHaskellType (ConT io `AppT` res) | io == ''IO -- is it an 'IO' function? 175 | = ([], [], True, res) 176 | splitHaskellType res 177 | = ([], [], False, res) 178 | 179 | makeStaticFunc (FuncDef (Func dspec f decl ps body loc1) loc2) 180 | = FuncDef (Func (addStatic dspec) f decl ps body loc1) loc2 181 | makeStaticFunc (FuncDef (OldFunc dspec f decl ps ig body loc1) loc2) 182 | = FuncDef (OldFunc (addStatic dspec) f decl ps ig body loc1) loc2 183 | makeStaticFunc def = def 184 | 185 | addStatic (DeclSpec st tqs ts loc) = DeclSpec (Tstatic loc:st) tqs ts loc 186 | addStatic (AntiTypeDeclSpec st tqs ts loc) = AntiTypeDeclSpec (Tstatic loc:st) tqs ts loc 187 | addStatic declSpec = declSpec 188 | 189 | maybeErrorCtype :: Maybe QC.Type -> QC.Type 190 | maybeErrorCtype Nothing = [cty| typename __UNDEFINED_TYPE |] -- placeholder to make progress in the face of errors 191 | maybeErrorCtype (Just ty) = ty 192 | 193 | forExpD :: Callconv -> String -> Name -> TypeQ -> DecQ 194 | forExpD cc str n ty 195 | = do 196 | { ty' <- ty 197 | ; return $ ForeignD (ExportF cc str n ty') 198 | } 199 | 200 | -- |Maps a quoted property to a quoted projection and a quoted update function in addition to the type of the projected 201 | -- value. 202 | -- 203 | data PropertyAccess = QC.ObjCIfaceDecl :==> (TH.TypeQ, TH.ExpQ, TH.ExpQ) 204 | 205 | -- |Map a property to explicit projection and update functions. 206 | -- 207 | (==>) :: ObjCIfaceDecl -> (TypeQ, ExpQ, ExpQ) -> PropertyAccess 208 | (==>) = (:==>) 209 | 210 | -- |Map a property to a field label. This function assumes that the field name is typed and can be reified. 211 | -- 212 | (-->) :: QC.ObjCIfaceDecl -> Name -> PropertyAccess 213 | prop --> fieldName = prop ==> (fieldTy, 214 | [| $(varE fieldName) |], 215 | [| \s v -> $(recUpdE [|s|] [do { vE <- [|v|]; return (fieldName, vE) }]) |]) 216 | where 217 | fieldTy 218 | = do 219 | { info <- reify fieldName 220 | ; case info of 221 | VarI _ (ArrowT `AppT` _ `AppT` resTy) _ _ -> return resTy 222 | nonVarInfo -> 223 | do 224 | { reportErrorAndFail QC.ObjC $ 225 | "expected '" ++ show fieldName ++ "' to be a typed record field name, but it is " ++ 226 | show (TH.ppr nonVarInfo) 227 | } 228 | } 229 | 230 | -- |Specification of a bridge for a Haskell structure that can be queried and updated from Objective-C. 231 | -- 232 | -- The first argument is the name of the Objective-C class that will be a proxy for the Haskell structure. 233 | -- The second argument the name of the Haskell type of the bridged Haskell structure. 234 | -- 235 | -- The generated class is immutable. When a property is updated, a new instance is allocated. This closely 236 | -- mirrors the behaviour of the Haskell structure for which the class is a proxy. 237 | -- 238 | -- The designated initialiser of the generated class is '[-initWithHsPtr:(HsStablePtr)particleHsPtr]', 239 | -- where '' is the type name of the Haskell structure. This initialiser is generated if it is not 240 | -- explicitly provided. The generated method '[-init]' calls the designated initialiser with 'nil' for the 241 | -- stable pointer. 242 | -- 243 | -- WARNING: This is a very experimental feature and it will SURELY change in the future!!! 244 | -- 245 | --FIXME: don't generate the designated initialiser if it is explicitly provided 246 | objc_record :: String -- ^prefix of the class name 247 | -> String -- ^class name 248 | -> TH.Name -- ^name of the Haskell type of the bridged Haskell structure 249 | -> [Annotated TH.Name] -- ^Haskell variables used in Objective-C code 250 | -> [PropertyAccess] -- ^Objective-C properties with corresponding Haskell projections and update functions 251 | -> [QC.ObjCIfaceDecl] -- ^extra interface declarations 252 | -> [QC.Definition] -- ^extra implementation declarations 253 | -> Q [TH.Dec] 254 | objc_record prefix objcClassName hsTyName ann_vars properties ifaceDecls impDecls 255 | | null objcClassName 256 | = reportErrorAndFail ObjC "empty class name" 257 | | otherwise 258 | = do 259 | { -- Turn projection and update functions into Haskell top-level function definitions 260 | ; let (propTys, propProjFuns, propUpdFuns) = unzip3 [(ty, proj, upd) | (_ :==> (ty, proj, upd)) <- properties] 261 | ; projNames <- sequence [ return . mkName $ "proj" ++ objcClassName ++ show i | (_, i) <- zip propProjFuns [(11::Int) ..]] 262 | ; updNames <- sequence [ return . mkName $ "upd" ++ objcClassName ++ show i | (_, i) <- zip propProjFuns [(11::Int) ..]] 263 | ; let projUpd_defs = [ funD name [clause [] (normalB propFun) []] 264 | | (name, propFun) <- zip projNames propProjFuns ++ zip updNames propUpdFuns] 265 | 266 | -- All new top-level functions are in the set of free variables for the implementation code 267 | ; let all_ann_vars = ann_vars ++ zipWith addProjType projNames propTys ++ zipWith addUpdType updNames propTys 268 | 269 | -- Construct the class interface 270 | ; let propertyDecls = [prop | (prop :==> _) <- properties] 271 | updateMethodDecls = concatMap mkUpdateMethodDecl propertyDecls 272 | iface = [cunit| 273 | @interface $id:prefixedClassName : NSObject 274 | 275 | $ifdecls:propertyDecls 276 | $ifdecls:updateMethodDecls 277 | $ifdecls:ifaceDecls 278 | 279 | @end 280 | |] 281 | 282 | -- Construct the class implementation 283 | ; let updateMethodDefs = concat $ zipWith mkUpdateMethodDef propertyDecls updNames 284 | projectionMethodDefs = concat $ zipWith mkProjectionMethodDef propertyDecls projNames 285 | imp = [cunit| 286 | @interface $id:prefixedClassName () 287 | @property (readonly, assign, nonatomic) typename HsStablePtr $id:hsPtrName; 288 | @end 289 | 290 | @implementation $id:prefixedClassName 291 | 292 | $edecls:updateMethodDefs 293 | $edecls:impDecls 294 | 295 | - (instancetype)init 296 | { 297 | return [self $id:initWithHsPtrName:nil]; 298 | } 299 | 300 | - (instancetype)$id:initWithHsPtrName:(typename HsStablePtr)$id:hsPtrName 301 | { 302 | self = [super init]; 303 | if (self) 304 | $id:("_" ++ hsPtrName) = $id:hsPtrName; 305 | return self; 306 | } 307 | 308 | - (void)dealloc 309 | { 310 | hs_free_stable_ptr($id:("_" ++ hsPtrName)); 311 | } 312 | 313 | $edecls:projectionMethodDefs 314 | 315 | @end 316 | |] 317 | 318 | -- Inline the class interface and class implementation; then, return all new Haskell bindings 319 | ; iface_defs <- objc_interface iface 320 | ; imp_defs <- objc_implementation all_ann_vars imp 321 | ; fun_defs <- sequence projUpd_defs 322 | ; return $ iface_defs ++ imp_defs ++ fun_defs 323 | } 324 | where 325 | addProjType name ty = name :> [t| $(conT hsTyName) -> $ty |] 326 | addUpdType name ty = name :> [t| $(conT hsTyName) -> $ty -> $(conT hsTyName) |] 327 | 328 | prefixedClassName = prefix ++ objcClassName 329 | lowerClassName = toLower (head objcClassName) : tail objcClassName 330 | hsTyNameBase = nameBase hsTyName 331 | lowerHsTyName = toLower (head hsTyNameBase) : tail hsTyNameBase 332 | hsPtrName = lowerHsTyName ++ "HsPtr" 333 | initWithHsPtrName = "initWith" ++ hsTyNameBase ++ "HsPtr" 334 | 335 | mkUpdateMethodDecl (ObjCIfaceProp _attrs 336 | (FieldGroup spec [Field (Just (Id propName _)) (Just decl) _exp _] loc) 337 | _) 338 | = [objcifdecls| 339 | + (instancetype)$id:lowerClassName:(typename $id:prefixedClassName *)$id:lowerClassName 340 | $id:("with" ++ upperPropName):($ty:propTy)$id:propName; 341 | |] 342 | where 343 | upperPropName = toUpper (head propName) : tail propName 344 | propTy = QC.Type spec decl loc 345 | 346 | mkUpdateMethodDef (ObjCIfaceProp _attrs 347 | (FieldGroup spec [Field (Just (Id propName _)) (Just decl) _exp _] loc) 348 | _) 349 | updName 350 | = [objcimdecls| 351 | + (instancetype)$id:lowerClassName:(typename $id:prefixedClassName *)$id:lowerClassName 352 | $id:("with" ++ upperPropName):($ty:propTy)$id:propName 353 | { 354 | return [[$id:prefixedClassName alloc] $id:initWithHsPtrName:$id:(show updName)($id:lowerClassName.$id:hsPtrName, 355 | $id:propName)]; 356 | } 357 | |] 358 | where 359 | upperPropName = toUpper (head propName) : tail propName 360 | propTy = QC.Type spec decl loc 361 | 362 | mkProjectionMethodDef (ObjCIfaceProp _attrs 363 | (FieldGroup spec [Field (Just (Id propName _)) (Just decl) _exp _] loc) 364 | _) 365 | updName 366 | = [objcimdecls| 367 | - ($ty:propTy)$id:propName 368 | { 369 | return $id:(show updName)(self.$id:hsPtrName); 370 | } 371 | |] 372 | where 373 | propTy = QC.Type spec decl loc 374 | 375 | -- |Declare a Haskell<->Objective-C marshaller pair to be used in all subsequent marshalling code generation. 376 | -- 377 | -- On the Objective-C side, the marshallers must use a wrapped foreign pointer to an Objective-C class (just as those 378 | -- of 'Class' hints). The domain and codomain of the two marshallers must be the opposite and both are executing in 'IO'. 379 | -- 380 | objc_marshaller :: TH.Name -> TH.Name -> Q [TH.Dec] 381 | objc_marshaller haskellToObjCName objcToHaskellName 382 | = do 383 | { -- check that the marshallers have compatible types 384 | ; (hsTy1, classTy1) <- argAndResultTy haskellToObjCName 385 | ; (classTy2, hsTy2) <- argAndResultTy objcToHaskellName 386 | ; unless (hsTy1 == hsTy2 && classTy1 == classTy2) $ 387 | reportErrorAndFail QC.ObjC $ 388 | "the two marshallers must map between the same types" 389 | 390 | ; tyconName <- headTyConNameOrError QC.ObjC classTy1 391 | ; let cTy = [cty| typename $id:(nameBase tyconName) * |] 392 | ; stashMarshaller (hsTy1, classTy1, cTy, haskellToObjCName, objcToHaskellName) 393 | ; return [] 394 | } 395 | where 396 | argAndResultTy name 397 | = do 398 | { info <- reify name 399 | ; case info of 400 | VarI _ (ArrowT `AppT` argTy `AppT` (ConT io `AppT` resTy)) _ _ 401 | | io == ''IO 402 | -> return (argTy, resTy) 403 | VarI _ _ _ _ -> reportErrorAndFail QC.ObjC $ 404 | show name ++ "'s type must match 'a -> IO r'" 405 | _ -> reportErrorAndFail QC.ObjC $ 406 | show name ++ " must be a function" 407 | } 408 | 409 | -- |Inline Objective-C expression. 410 | -- 411 | -- The inline expression will be wrapped in a C function whose arguments are marshalled versions of the Haskell 412 | -- variables given in the first argument. The marshalling of the variables and of the result is determined by the 413 | -- marshalling annotations at the variables and the inline expression. 414 | -- 415 | objc :: [Annotated TH.Name] -> Annotated QC.Exp -> Q TH.Exp 416 | objc ann_vars ann_e 417 | = {- tryWithPlaceholder $ -} do -- FIXME: catching the 'fail' purges all reported errors :( 418 | { -- Sanity check of arguments 419 | ; let vars = map stripAnnotation ann_vars 420 | ; varTys <- mapM haskellTypeOf ann_vars 421 | ; resTy <- haskellTypeOf ann_e 422 | 423 | -- Determine C types 424 | ; maybe_cArgTys <- mapM annotatedHaskellTypeToCType ann_vars 425 | ; maybe_cResTy <- annotatedHaskellTypeToCType ann_e 426 | ; let cannotMapAllTypes = Nothing `elem` (maybe_cResTy : maybe_cArgTys) 427 | cArgTys = map maybeErrorCtype maybe_cArgTys 428 | cResTy = maybeErrorCtype maybe_cResTy 429 | 430 | ; if cannotMapAllTypes 431 | then failOn [ann_var | (ann_var, Nothing) <- zip ann_vars maybe_cArgTys] maybe_cResTy 432 | else do 433 | 434 | { -- Determine the bridging type and the marshalling code 435 | ; (bridgeArgTys, cBridgeArgTys, hsArgMarshallers, cArgMarshallers) <- 436 | unzip4 <$> zipWithM generateHaskellToCMarshaller varTys cArgTys 437 | ; (bridgeResTy, cBridgeResTy, hsResMarshaller, cResMarshaller) <- 438 | generateCToHaskellMarshaller resTy cResTy 439 | 440 | -- Haskell type of the foreign wrapper function 441 | ; let hsWrapperTy = haskellWrapperType [] bridgeArgTys bridgeResTy 442 | 443 | -- FFI setup for the C wrapper 444 | ; cwrapperName <- show <$> newName "cwrapper" >>= newName -- Don't ask... 445 | ; stashHS 446 | [ forImpD CCall Safe (show cwrapperName) cwrapperName hsWrapperTy 447 | ] 448 | ; idx <- extendJumpTable cwrapperName 449 | 450 | -- Generate the C wrapper code (both prototype and definition) 451 | ; cArgVars <- mapM (newName . nameBase) vars 452 | ; let (wrapperProto, wrapperDef) 453 | = generateCWrapper cwrapperName cArgTys vars cArgMarshallers cBridgeArgTys cArgVars 454 | (stripAnnotation ann_e) 455 | resTy cResTy cResMarshaller cBridgeResTy 456 | ; stashObjC_h wrapperProto 457 | ; stashObjC_m wrapperDef 458 | 459 | -- Generate invocation of the C wrapper sandwiched into Haskell-side marshalling 460 | ; generateHSCall vars hsArgMarshallers (callThroughTable idx hsWrapperTy) hsResMarshaller True 461 | } } 462 | where 463 | callThroughTable idx ty 464 | = do { jumptable <- getForeignTable 465 | ; [|fromDyn 466 | ((unsafePerformIO $ readIORef $jumptable) ! $(TH.lift idx)) 467 | (error "InlineObjC: INTERNAL ERROR: type mismatch in jumptable") 468 | :: $ty |] 469 | } 470 | 471 | failOn err_ann_vars maybe_cResTy 472 | = do 473 | { unless (null err_ann_vars) $ do 474 | { var_strs <- mapM annotatedShowQ err_ann_vars 475 | ; reportErrorWithLang ObjC $ "invalid marshalling: " ++ intercalate ", " var_strs 476 | } 477 | ; unless (isJust maybe_cResTy) $ do 478 | { ty <- haskellTypeOf ann_e 479 | ; reportErrorWithLang ObjC $ "invalid marshalling for result type " ++ show ty 480 | } 481 | ; [| error "error in inline Objective-C expression" |] 482 | } 483 | 484 | annotatedHaskellTypeToCType ann 485 | = do 486 | { maybe_objcType <- foreignTypeOf ann 487 | ; case maybe_objcType of 488 | Nothing -> haskellTypeOf ann >>= haskellTypeToCType ObjC 489 | Just objcType -> return $ Just objcType 490 | } 491 | 492 | -- Turn a list of argument types and a result type into a Haskell wrapper signature. 493 | -- 494 | -- > haskellWrapperType [tv1, .., tvm] [a1, .., an] r = [| forall tv1 .. tvm. a1 -> .. -> an -> IO r |] 495 | -- 496 | haskellWrapperType :: [TH.TyVarBndr] -> [TH.TypeQ] -> TH.TypeQ -> TH.TypeQ 497 | haskellWrapperType [] argTys resTy = wrapperBodyType argTys resTy -- monotype 498 | haskellWrapperType tvs argTys resTy = forallT tvs (cxt []) (wrapperBodyType argTys resTy) -- polytype 499 | 500 | wrapperBodyType :: [TH.TypeQ] -> TH.TypeQ -> TH.TypeQ 501 | wrapperBodyType [] resTy = [t| IO $resTy |] 502 | wrapperBodyType (argTy:argTys) resTy = [t| $argTy -> $(wrapperBodyType argTys resTy) |] 503 | 504 | -- Generate the prototype of and function definition of a C marshalling wrapper. 505 | -- 506 | -- Given a C expression to be executed, this generator produces a C function that executes the expression with all 507 | -- arguments and the result marshalled using the provided marshallers. 508 | -- 509 | generateCWrapper :: TH.Name 510 | -> [QC.Type] 511 | -> [TH.Name] -- name of arguments after marshalling (will be the original name without unique) 512 | -> [CMarshaller] 513 | -> [QC.Type] 514 | -> [TH.Name] 515 | -> QC.Exp -- C expression containing occurences of the arguments (using names without uniques) 516 | -> TH.Type 517 | -> QC.Type 518 | -> CMarshaller 519 | -> QC.Type 520 | -> ([QC.Definition], [QC.Definition]) 521 | generateCWrapper cwrapperName argTys vars argMarshallers cWrapperArgTys argVars e hsResTy resTy resMarshaller cWrapperResTy 522 | = let cMarshalling = [ [citem| $ty:argTy $id:(nameBase var) = $exp:(argMarshaller argVar); |] 523 | | (argTy, var, argMarshaller, argVar) <- zip4 argTys vars argMarshallers argVars] 524 | resultName = mkName "result" 525 | cInvocation | hsResTy == (ConT ''()) = [citem| $exp:e; |] -- void result 526 | | otherwise = [citem| { 527 | $ty:resTy $id:(show resultName) = $exp:e; // non-void result... 528 | return $exp:(resMarshaller resultName); // ...marshalled to Haskell 529 | }|] 530 | in 531 | ([cunit| 532 | $ty:cWrapperResTy $id:(show cwrapperName) ($params:(cParams cWrapperArgTys argVars)); 533 | |], 534 | [cunit| 535 | $ty:cWrapperResTy $id:(show cwrapperName) ($params:(cParams cWrapperArgTys argVars)) 536 | { 537 | $items:cMarshalling 538 | $item:cInvocation 539 | } 540 | |]) 541 | 542 | -- cParams [a1, .., an] [v1, .., vn] = [[cparam| a1 v1 |], .., [cparam| an vn |]] 543 | -- 544 | -- * If the list is empty, we will return a singleton 'void' parameter. 545 | -- 546 | cParams :: [QC.Type] -> [TH.Name] -> [QC.Param] 547 | cParams [] [] = [ [cparam| void |] ] 548 | cParams tys names = cParams' tys names 549 | where 550 | cParams' [] [] = [] 551 | cParams' (argTy:argTys) (var:vars) = [cparam| $ty:argTy $id:(show var) |] : cParams' argTys vars 552 | 553 | 554 | -- Produce a Haskell expression that calls a function with all arguments and the result marshalled with the supplied 555 | -- marshallers. 556 | -- 557 | generateHSCall :: [TH.Name] 558 | -> [HaskellMarshaller] 559 | -> TH.ExpQ 560 | -> HaskellMarshaller 561 | -> Bool 562 | -> TH.ExpQ 563 | generateHSCall vars hsArgMarshallers f hsResMarshaller inIO 564 | = invoke [hsArgMarshaller (varE var) | (var, hsArgMarshaller) <- zip vars hsArgMarshallers] 565 | f 566 | (if inIO then [| \call -> do { cresult <- call ; $(hsResMarshaller [|cresult|] [|return|]) } |] 567 | else [| \call -> do { let {cresult = call}; $(hsResMarshaller [|cresult|] [|return|]) } |]) 568 | where 569 | -- invoke [v1, .., vn] [a1, .., an] call r = [| a1 (\v1 -> .. -> an (\vn -> r (call v1 .. vn))..) |] 570 | invoke :: [TH.ExpQ -> TH.ExpQ] -> TH.ExpQ -> TH.ExpQ -> TH.ExpQ 571 | invoke [] call ret = [| $ret $call |] 572 | invoke (arg:args) call ret = arg [| \name -> $(invoke args [| $call name |] ret)|] 573 | 574 | -- |Emit the Objective-C file and return the foreign declarations. Needs to be the last use of an 'objc...' function. 575 | -- (Just put it at the end of the Haskell module.) 576 | -- 577 | objc_emit :: Q [TH.Dec] 578 | objc_emit 579 | = do 580 | { loc <- location 581 | ; let origFname = loc_filename loc 582 | objcFname = dropExtension origFname ++ "_objc" 583 | objcFname_h = objcFname `addExtension` "h" 584 | objcFname_m = objcFname `addExtension` "m" 585 | ; headers <- getHeaders 586 | ; (objc_h, objc_m) <- getHoistedObjC 587 | ; runIO $ 588 | do 589 | { writeFile objcFname_h (info origFname) 590 | ; appendFile objcFname_h (unlines (map mkImport headers) ++ "\n") 591 | ; appendFile objcFname_h (show $ QC.ppr objc_h) 592 | ; writeFile objcFname_m (info origFname) 593 | ; appendFile objcFname_m ("#import \"" ++ takeFileName objcFname_h ++ "\"\n") 594 | ; appendFile objcFname_m ("#import \"HsFFI.h\"\n\n") 595 | ; appendFile objcFname_m (show $ QC.ppr objc_m) 596 | } 597 | ; objc_jumptable <- getForeignTable 598 | ; labels <- getForeignLabels 599 | ; initialize <- [d|objc_initialise :: IO () 600 | objc_initialise 601 | = -- unsafePerformIO $ 602 | writeIORef $objc_jumptable $ 603 | listArray ($(lift (1::Int)), $(lift $ length labels)) $ 604 | $(listE [ [|toDyn $(varE label)|] | label <- labels]) 605 | |] 606 | ; (initialize ++) <$> getHoistedHS 607 | } 608 | where 609 | mkImport h@('<':_) = "#import " ++ h ++ "" 610 | mkImport h = "#import \"" ++ h ++ "\"" 611 | 612 | info fname = "// Generated code: DO NOT EDIT\n\ 613 | \// generated from '" ++ fname ++ "'\n\ 614 | \// by package 'language-c-inline'\n\n" 615 | 616 | -- |Force type checking of all declaration appearing earlier in this module. 617 | -- 618 | -- Template Haskell performs type checking on declaration groups seperated by toplevel splices. In order for a type 619 | -- declaration to be available to an Objective-C inline directive, the type declaration must be in an earlier 620 | -- declaration group than the Objective-C inline directive. A toplevel Objective-C inline directive always is the start 621 | -- of a new declaration group; hence, it can be considered to be implicitly preceded by an 'objc_typecheck'. 622 | -- 623 | objc_typecheck :: Q [TH.Dec] 624 | objc_typecheck = return [] 625 | -------------------------------------------------------------------------------- /Language/C/Inline/ObjC/Hint.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, GADTs, TemplateHaskell, QuasiQuotes #-} 2 | 3 | -- | 4 | -- Module : Language.C.Inline.ObjC.Hint 5 | -- Copyright : 2014 Manuel M T Chakravarty 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Manuel M T Chakravarty 9 | -- Stability : experimental 10 | -- Portability : non-portable (GHC extensions) 11 | -- 12 | -- This module provides Objective-C specific hints. 13 | 14 | module Language.C.Inline.ObjC.Hint ( 15 | -- * Class hints 16 | Class(..), IsType 17 | ) where 18 | 19 | -- standard libraries 20 | import Language.Haskell.TH as TH 21 | 22 | -- quasi-quotation libraries 23 | import Language.C.Quote as QC 24 | import Language.C.Quote.ObjC as QC 25 | 26 | -- friends 27 | import Language.C.Inline.Error 28 | import Language.C.Inline.Hint 29 | import Language.C.Inline.TH 30 | 31 | 32 | -- |Class of entities that can be used as TH types. 33 | -- 34 | class IsType ty where 35 | theType :: ty -> Q TH.Type 36 | 37 | instance IsType TH.Type where 38 | theType = return 39 | 40 | instance IsType (Q TH.Type) where 41 | theType = id 42 | 43 | instance IsType TH.Name where 44 | theType name 45 | = do 46 | { info <- reify name 47 | ; case info of 48 | TyConI _ -> return $ ConT name 49 | PrimTyConI _ _ _ -> return $ ConT name 50 | FamilyI _ _ -> return $ ConT name 51 | _ -> 52 | do 53 | { reportErrorAndFail QC.ObjC $ 54 | "expected '" ++ show name ++ "' to be a type name, but it is " ++ 55 | show (TH.ppr info) 56 | } 57 | } 58 | 59 | -- |Hint indicating to marshal an Objective-C object as a foreign pointer, where the argument is the Haskell type 60 | -- representing the Objective-C class. The Haskell type name must coincide with the Objective-C class name. 61 | -- 62 | data Class where 63 | Class :: IsType t => t -> Class 64 | 65 | instance Hint Class where 66 | haskellType (Class tyish) 67 | = do 68 | { ty <- theType tyish 69 | ; _ <- foreignWrapperDatacon ty -- FAILS if the declaration is not a 'ForeignPtr' wrapper 70 | ; return ty 71 | } 72 | foreignType (Class tyish) 73 | = do 74 | { name <- theType tyish >>= headTyConNameOrError QC.ObjC 75 | ; return $ Just [cty| typename $id:(nameBase name) * |] 76 | } 77 | showQ (Class tyish) 78 | = do 79 | { ty <- theType tyish 80 | ; return $ "Class " ++ show ty 81 | } 82 | -------------------------------------------------------------------------------- /Language/C/Inline/ObjC/Marshal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternGuards, TemplateHaskell, QuasiQuotes #-} 2 | 3 | -- | 4 | -- Module : Language.C.Inline.ObjC.Marshal 5 | -- Copyright : [2013] Manuel M T Chakravarty 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Manuel M T Chakravarty 9 | -- Stability : experimental 10 | -- Portability : non-portable (GHC extensions) 11 | -- 12 | -- Objective-C-specific marshalling functions. 13 | -- 14 | -- FIXME: Some of the code can go into a module for general marshalling, as only some of it is ObjC-specific. 15 | 16 | module Language.C.Inline.ObjC.Marshal ( 17 | -- * Determine corresponding foreign types of Haskell types 18 | haskellTypeToCType, 19 | 20 | -- * Marshaller types 21 | HaskellMarshaller, CMarshaller, 22 | 23 | -- * Compute bridging types and marshallers 24 | generateHaskellToCMarshaller, generateCToHaskellMarshaller 25 | ) where 26 | 27 | -- common libraries 28 | import Data.Map as Map 29 | import Data.Word 30 | import Foreign.C as C 31 | import Foreign.Marshal as C 32 | import Foreign.Ptr as C 33 | import Foreign.ForeignPtr as C 34 | import Foreign.StablePtr as C 35 | import Language.Haskell.TH as TH 36 | 37 | -- quasi-quotation libraries 38 | import Language.C.Quote as QC 39 | import Language.C.Quote.ObjC as QC 40 | 41 | -- friends 42 | import Language.C.Inline.Error 43 | import Language.C.Inline.State 44 | import Language.C.Inline.TH 45 | 46 | 47 | -- Determine foreign types 48 | -- ----------------------- 49 | 50 | -- |Determine the C type that we map a given Haskell type to. 51 | -- 52 | haskellTypeToCType :: QC.Extensions -> TH.Type -> Q (Maybe QC.Type) 53 | haskellTypeToCType lang (ForallT _tvs _ctxt ty) -- ignore quantifiers and contexts 54 | = haskellTypeToCType lang ty 55 | haskellTypeToCType lang ty 56 | = do 57 | { maybe_marshaller <- lookupMarshaller ty 58 | ; case maybe_marshaller of 59 | Just (_, _, cTy, _, _) -> return $ Just cTy -- use a custom marshaller if one is available for this type 60 | Nothing -> haskellTypeToCType' lang ty -- otherwise, continue below... 61 | } 62 | where 63 | haskellTypeToCType' lang' (ListT `AppT` (ConT ch)) -- marshal '[Char]' as 'String' 64 | | ch == ''Char 65 | = haskellTypeNameToCType lang' ''String 66 | haskellTypeToCType' lang' ty'@(ConT maybeC `AppT` argTy) -- encode a 'Maybe' around a pointer type in the pointer 67 | | maybeC == ''Maybe 68 | = do 69 | { cargTy <- haskellTypeToCType lang argTy 70 | ; if fmap isCPtrType cargTy == Just True 71 | then 72 | return cargTy 73 | else 74 | unknownType lang' ty' 75 | } 76 | haskellTypeToCType' lang' (ConT tc) -- nullary type constructors are delegated 77 | = haskellTypeNameToCType lang' tc 78 | haskellTypeToCType' lang' ty'@(VarT _) -- can't marshal an unknown type 79 | = unknownType lang' ty' 80 | haskellTypeToCType' lang' ty'@(UnboxedTupleT _) -- there is nothing like unboxed tuples in C 81 | = unknownType lang' ty' 82 | haskellTypeToCType' _lang _ty -- everything else is marshalled as a stable pointer 83 | = return $ Just [cty| typename HsStablePtr |] 84 | 85 | unknownType lang' ty' 86 | = do 87 | { reportErrorWithLang lang' $ "don't know a foreign type suitable for Haskell type '" ++ TH.pprint ty' ++ "'" 88 | ; return Nothing 89 | } 90 | 91 | -- |Determine the C type that we map a given Haskell type constructor to — i.e., we map all Haskell types 92 | -- whose outermost constructor is the given type constructor to the returned C type. 93 | -- 94 | -- All types representing boxed values that are not explicitly mapped to a specific C type, are mapped to 95 | -- stable pointers. 96 | -- 97 | haskellTypeNameToCType :: QC.Extensions -> TH.Name -> Q (Maybe QC.Type) 98 | haskellTypeNameToCType ext tyname 99 | = case Map.lookup tyname (haskellToCTypeMap ext) of 100 | Just c -> return $ Just c 101 | Nothing -> do 102 | { info <- reify tyname 103 | ; case info of 104 | PrimTyConI _ _ True -> unknownUnboxedType 105 | _ -> return $ Just [cty| typename HsStablePtr |] 106 | } 107 | where 108 | unknownUnboxedType = do 109 | { reportErrorWithLang ext $ 110 | "don't know a foreign type suitable for the unboxed Haskell type '" ++ show tyname ++ "'" 111 | ; return Nothing 112 | } 113 | 114 | haskellToCTypeMap :: QC.Extensions -> Map TH.Name QC.Type 115 | haskellToCTypeMap ObjC 116 | = Map.fromList 117 | [ (''CChar, [cty| char |]) 118 | , (''CSChar, [cty| signed char |]) 119 | , (''CUChar, [cty| unsigned char |]) 120 | , (''CShort, [cty| short |]) 121 | , (''CUShort, [cty| unsigned short |]) 122 | , (''Int, [cty| typename NSInteger |]) 123 | , (''CInt, [cty| int |]) 124 | , (''Word, [cty| typename NSUInteger |]) 125 | , (''CUInt, [cty| unsigned int |]) 126 | , (''CLong, [cty| long |]) 127 | , (''CULong, [cty| unsigned long |]) 128 | , (''CLLong, [cty| long long |]) 129 | , (''CULLong, [cty| unsigned long long |]) 130 | -- 131 | , (''Float, [cty| float |]) 132 | , (''CFloat, [cty| float |]) 133 | , (''Double, [cty| double |]) 134 | , (''CDouble, [cty| double |]) 135 | -- 136 | , (''Bool, [cty| typename BOOL |]) 137 | , (''String, [cty| typename NSString * |]) 138 | , (''(), [cty| void |]) 139 | ] 140 | haskellToCTypeMap _lang 141 | = Map.empty 142 | 143 | -- Check whether the given C type is an overt pointer. 144 | -- 145 | isCPtrType :: QC.Type -> Bool 146 | isCPtrType (Type _ (Ptr {}) _) = True 147 | isCPtrType (Type _ (BlockPtr {}) _) = True 148 | isCPtrType (Type _ (Array {}) _) = True 149 | isCPtrType ty 150 | | ty == [cty| typename HsStablePtr |] = True 151 | | otherwise = False 152 | 153 | 154 | -- Determine marshallers and their bridging types 155 | -- ---------------------------------------------- 156 | 157 | -- |Constructs Haskell code to marshal a value (used to marshal arguments and results). 158 | -- 159 | -- * The first argument is the code referring to the value to be marshalled. 160 | -- * The second argument is the continuation that gets the marshalled value as an argument. 161 | -- 162 | type HaskellMarshaller = TH.ExpQ -> TH.ExpQ -> TH.ExpQ 163 | 164 | -- |Constructs C code to marshal an argument (used to marshal arguments and results). 165 | -- 166 | -- * The argument is the identifier of the value to be marshalled. 167 | -- * The result of the generated expression is the marshalled value. 168 | -- 169 | type CMarshaller = TH.Name -> QC.Exp 170 | 171 | -- |Generate the type-specific marshalling code for Haskell to C land marshalling for a Haskell-C type pair. 172 | -- 173 | -- The result has the following components: 174 | -- 175 | -- * Haskell type after Haskell-side marshalling. 176 | -- * C type before C-side marshalling. 177 | -- * Generator for the Haskell-side marshalling code. 178 | -- * Generator for the C-side marshalling code. 179 | -- 180 | generateHaskellToCMarshaller :: TH.Type -> QC.Type -> Q (TH.TypeQ, QC.Type, HaskellMarshaller, CMarshaller) 181 | generateHaskellToCMarshaller hsTy cTy@(Type (DeclSpec _ _ (Tnamed (Id name _) _ _) _) (Ptr _ (DeclRoot _) _) _) 182 | | Just name == maybeHeadName -- wrapped ForeignPtr mapped to an Objective-C class 183 | = return ( ptrOfForeignPtrWrapper hsTy 184 | , cTy 185 | , \val cont -> [| C.withForeignPtr ($(unwrapForeignPtrWrapper hsTy) $val) $cont |] 186 | , \argName -> [cexp| $id:(show argName) |] 187 | ) 188 | | otherwise 189 | = do 190 | { maybe_marshaller <- lookupMarshaller hsTy 191 | ; case maybe_marshaller of 192 | Just (_, classTy, cTy', haskellToC, _cToHaskell) 193 | | cTy' == cTy -- custom marshaller mapping to an Objective-C class 194 | -> return ( ptrOfForeignPtrWrapper classTy 195 | , cTy 196 | , \val cont -> [| do 197 | { nsClass <- $(varE haskellToC) $val 198 | ; C.withForeignPtr ($(unwrapForeignPtrWrapper classTy) nsClass) $cont 199 | } |] 200 | , \argName -> [cexp| $id:(show argName) |] 201 | ) 202 | Nothing -- other => continue below 203 | -> generateHaskellToCMarshaller' hsTy cTy 204 | } 205 | where 206 | maybeHeadName = fmap nameBase $ headTyConName hsTy 207 | generateHaskellToCMarshaller hsTy cTy = generateHaskellToCMarshaller' hsTy cTy 208 | 209 | generateHaskellToCMarshaller' :: TH.Type -> QC.Type -> Q (TH.TypeQ, QC.Type, HaskellMarshaller, CMarshaller) 210 | generateHaskellToCMarshaller' hsTy@(ConT mbe `AppT` argTy) cTy 211 | | mbe == ''Maybe && isCPtrType cTy 212 | = do 213 | { (argTy', cTy', hsMarsh, cMarsh) <- generateHaskellToCMarshaller argTy cTy 214 | ; ty <- argTy' 215 | ; resolve ty argTy' cTy' hsMarsh cMarsh 216 | } 217 | where 218 | resolve ty argTy' cTy' hsMarsh cMarsh 219 | = case ty of 220 | ConT ptr `AppT` _ 221 | | ptr == ''C.Ptr -> return ( argTy' 222 | , cTy' 223 | , \val cont -> [| case $val of 224 | Nothing -> $cont C.nullPtr 225 | Just val' -> $(hsMarsh [|val'|] cont) |] 226 | , cMarsh 227 | ) 228 | | ptr == ''C.StablePtr -> return ( argTy' 229 | , cTy' 230 | , \val cont -> [| case $val of 231 | Nothing -> $cont (C.castPtrToStablePtr C.nullPtr) 232 | Just val' -> $(hsMarsh [|val'|] cont) |] 233 | -- NB: the above cast works for GHC, but is in the grey area 234 | -- of the FFI spec 235 | , cMarsh 236 | ) 237 | ConT con 238 | -> do 239 | { info <- reify con 240 | ; case info of 241 | TyConI (TySynD _name [] tysyn) -> resolve tysyn argTy' cTy' hsMarsh cMarsh 242 | -- chase type synonyms (only nullary ones at the moment) 243 | _ -> missingErr 244 | } 245 | _ -> missingErr 246 | missingErr = reportErrorAndFail ObjC $ 247 | "missing 'Maybe' marshalling for '" ++ prettyQC cTy ++ "' to '" ++ TH.pprint hsTy ++ "'" 248 | generateHaskellToCMarshaller' hsTy cTy 249 | | Just hsMarshalTy <- Map.lookup cTy cIntegralMap -- checking whether it is an integral type 250 | = return ( hsMarshalTy 251 | , cTy 252 | , \val cont -> [| $cont (fromIntegral $val) |] 253 | , \argName -> [cexp| $id:(show argName) |] 254 | ) 255 | | Just hsMarshalTy <- Map.lookup cTy cFloatingMap -- checking whether it is a floating type 256 | = return ( hsMarshalTy 257 | , cTy 258 | , \val cont -> [| $cont (realToFrac $val) |] 259 | , \argName -> [cexp| $id:(show argName) |] 260 | ) 261 | | cTy == [cty| typename BOOL |] 262 | = return ( [t| C.CSChar |] 263 | , cTy 264 | , \val cont -> [| $cont (C.fromBool $val) |] 265 | , \argName -> [cexp| ($id:(show argName)) |] 266 | ) 267 | | cTy == [cty| typename NSString * |] 268 | = return ( [t| C.CString |] 269 | , [cty| char * |] 270 | , \val cont -> [| C.withCString $val $cont |] 271 | , \argName -> [cexp| ($id:(show argName)) ? [NSString stringWithUTF8String: $id:(show argName)] : nil |] 272 | ) 273 | | cTy == [cty| typename HsStablePtr |] 274 | = return ( [t| C.StablePtr $(return hsTy) |] 275 | , cTy 276 | , \val cont -> [| do { C.newStablePtr $val >>= $cont } |] 277 | , \argName -> [cexp| $id:(show argName) |] 278 | ) 279 | | otherwise 280 | = reportErrorAndFail ObjC $ "cannot marshal '" ++ TH.pprint hsTy ++ "' to '" ++ prettyQC cTy ++ "'" 281 | 282 | -- |Generate the type-specific marshalling code for Haskell to C land marshalling for a C-Haskell type pair. 283 | -- 284 | -- The result has the following components: 285 | -- 286 | -- * Haskell type after Haskell-side marshalling. 287 | -- * C type before C-side marshalling. 288 | -- * Generator for the Haskell-side marshalling code. 289 | -- * Generator for the C-side marshalling code. 290 | -- 291 | generateCToHaskellMarshaller :: TH.Type -> QC.Type -> Q (TH.TypeQ, QC.Type, HaskellMarshaller, CMarshaller) 292 | generateCToHaskellMarshaller hsTy cTy@(Type (DeclSpec _ _ (Tnamed (Id name _) _ _) _) (Ptr _ (DeclRoot _) _) _) 293 | | Just name == maybeHeadName -- ForeignPtr mapped to an Objective-C class 294 | = return ( ptrOfForeignPtrWrapper hsTy 295 | , cTy 296 | , \val cont -> do { let datacon = foreignWrapperDatacon hsTy 297 | ; [| do { fptr <- newForeignPtr_ $val; $cont ($datacon fptr) } |] 298 | } 299 | , \argName -> [cexp| $id:(show argName) |] 300 | ) 301 | | otherwise 302 | = do 303 | { maybe_marshaller <- lookupMarshaller hsTy 304 | ; case maybe_marshaller of 305 | Just (_, classTy, cTy', _haskellToC, cToHaskell) 306 | | cTy' == cTy -- custom marshaller mapping to an Objective-C class 307 | -> return ( ptrOfForeignPtrWrapper classTy 308 | , cTy 309 | , \val cont -> do { let datacon = foreignWrapperDatacon classTy 310 | ; [| do 311 | { fptr <- newForeignPtr_ $val 312 | ; hsVal <- $(varE cToHaskell) ($datacon fptr) 313 | ; $cont hsVal 314 | } |] 315 | } 316 | , \argName -> [cexp| $id:(show argName) |] 317 | ) 318 | Nothing -- other => continue below 319 | -> generateCToHaskellMarshaller' hsTy cTy 320 | } 321 | where 322 | maybeHeadName = fmap nameBase $ headTyConName hsTy 323 | generateCToHaskellMarshaller hsTy cTy = generateCToHaskellMarshaller' hsTy cTy 324 | 325 | generateCToHaskellMarshaller' :: TH.Type -> QC.Type -> Q (TH.TypeQ, QC.Type, HaskellMarshaller, CMarshaller) 326 | generateCToHaskellMarshaller' hsTy@(ConT mbe `AppT` argTy) cTy 327 | | mbe == ''Maybe && isCPtrType cTy 328 | = do 329 | { (argTy', cTy', hsMarsh, cMarsh) <- generateCToHaskellMarshaller argTy cTy 330 | ; ty <- argTy' 331 | ; resolve ty argTy' cTy' hsMarsh cMarsh 332 | } 333 | where 334 | resolve ty argTy' cTy' hsMarsh cMarsh 335 | = case ty of 336 | ConT ptr `AppT` _ 337 | | ptr == ''C.Ptr -> return ( argTy' 338 | , cTy' 339 | , \val cont -> [| if $val == C.nullPtr 340 | then $cont Nothing 341 | else $(hsMarsh val [| $cont . Just |]) |] 342 | , cMarsh 343 | ) 344 | | ptr == ''C.StablePtr -> return ( argTy' 345 | , cTy' 346 | , \val cont -> [| if (C.castStablePtrToPtr $val) == C.nullPtr 347 | then $cont Nothing 348 | else $(hsMarsh val [| $cont . Just |]) |] 349 | -- NB: the above cast works for GHC, but is in the grey area 350 | -- of the FFI spec 351 | , cMarsh 352 | ) 353 | ConT con 354 | -> do 355 | { info <- reify con 356 | ; case info of 357 | TyConI (TySynD _name [] tysyn) -> resolve tysyn argTy' cTy' hsMarsh cMarsh 358 | -- chase type synonyms (only nullary ones at the moment) 359 | _ -> missingErr 360 | } 361 | _ -> missingErr 362 | missingErr = reportErrorAndFail ObjC $ 363 | "missing 'Maybe' marshalling for '" ++ prettyQC cTy ++ "' to '" ++ TH.pprint hsTy ++ "'" 364 | generateCToHaskellMarshaller' hsTy cTy 365 | | Just hsMarshalTy <- Map.lookup cTy cIntegralMap -- checking whether it is an integral type 366 | = return ( hsMarshalTy 367 | , cTy 368 | , \val cont -> [| $cont (fromIntegral $val) |] 369 | , \argName -> [cexp| $id:(show argName) |] 370 | ) 371 | | Just hsMarshalTy <- Map.lookup cTy cFloatingMap -- checking whether it is a floating type 372 | = return ( hsMarshalTy 373 | , cTy 374 | , \val cont -> [| $cont (realToFrac $val) |] 375 | , \argName -> [cexp| $id:(show argName) |] 376 | ) 377 | | cTy == [cty| typename BOOL |] 378 | = return ( [t| C.CSChar |] 379 | , cTy 380 | , \val cont -> [| $cont (C.toBool $val) |] 381 | , \argName -> [cexp| $id:(show argName) |] 382 | ) 383 | | cTy == [cty| typename NSString * |] 384 | = return ( [t| C.CString |] 385 | , [cty| char * |] 386 | , \val cont -> [| do { str <- C.peekCString $val; C.free $val; $cont str } |] 387 | , \argName -> 388 | let arg = show argName 389 | in 390 | [cexp| 391 | ( $id:arg ) 392 | ? ({ typename NSUInteger maxLen = [$id:arg maximumLengthOfBytesUsingEncoding:NSUTF8StringEncoding] + 1; 393 | char *buffer = malloc (maxLen); 394 | if (![$id:arg getCString:buffer maxLength:maxLen encoding:NSUTF8StringEncoding]) 395 | *buffer = '\0'; 396 | buffer; 397 | }) 398 | : nil 399 | |] 400 | ) 401 | | cTy == [cty| typename HsStablePtr |] 402 | = return ( [t| C.StablePtr $(return hsTy) |] 403 | , cTy 404 | , \val cont -> [| do { C.deRefStablePtr $val >>= $cont } |] 405 | , \argName -> [cexp| $id:(show argName) |] 406 | ) 407 | | cTy == [cty| void |] 408 | = return ( [t| () |] 409 | , [cty| void |] 410 | , \val cont -> [| $cont $val |] 411 | , \argName -> [cexp| $id:(show argName) |] 412 | ) 413 | | otherwise 414 | = reportErrorAndFail ObjC $ "cannot marshall '" ++ prettyQC cTy ++ "' to '" ++ TH.pprint hsTy ++ "'" 415 | 416 | cIntegralMap :: Map QC.Type TypeQ 417 | cIntegralMap = Map.fromList 418 | [ ([cty| char |], [t| C.CChar |]) 419 | , ([cty| signed char |], [t| C.CChar |]) 420 | , ([cty| unsigned char |], [t| C.CUChar |]) 421 | , ([cty| short |], [t| C.CShort |]) 422 | , ([cty| unsigned short |], [t| C.CUShort |]) 423 | , ([cty| int |], [t| C.CInt |]) 424 | , ([cty| unsigned int |], [t| C.CUInt |]) 425 | , ([cty| long |], [t| C.CLong |]) 426 | , ([cty| unsigned long |], [t| C.CULong |]) 427 | , ([cty| long long |], [t| C.CLLong |]) 428 | , ([cty| unsigned long long |], [t| C.CULLong |]) 429 | , ([cty| typename NSInteger |], [t| Int |]) 430 | , ([cty| typename NSUInteger |], [t| Word |]) 431 | ] 432 | 433 | cFloatingMap :: Map QC.Type TypeQ 434 | cFloatingMap = Map.fromList 435 | [ ([cty| float |] , [t| C.CFloat |]) 436 | , ([cty| double |], [t| C.CDouble |]) 437 | ] 438 | -------------------------------------------------------------------------------- /Language/C/Inline/State.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, QuasiQuotes #-} 2 | 3 | -- | 4 | -- Module : Language.C.Inline.State 5 | -- Copyright : [2013] Manuel M T Chakravarty 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Manuel M T Chakravarty 9 | -- Stability : experimental 10 | -- Portability : non-portable (GHC extensions) 11 | -- 12 | -- This module manages the state accumulated during the compilation of one module. 13 | 14 | module Language.C.Inline.State ( 15 | -- * Abstract application state 16 | State, 17 | 18 | -- * State query and update operations 19 | setForeignTable, stashHeader, stashMarshaller, stashObjC_h, stashObjC_m, stashHS, 20 | extendJumpTable, 21 | getForeignTable, getForeignLabels, getHeaders, getMarshallers, lookupMarshaller, getHoistedObjC, getHoistedHS 22 | ) where 23 | 24 | -- common libraries 25 | import Control.Applicative 26 | import Data.IORef 27 | import Language.Haskell.TH as TH 28 | import System.IO.Unsafe (unsafePerformIO) 29 | 30 | -- quasi-quotation libraries 31 | import Language.C.Quote as QC 32 | 33 | 34 | type CustomMarshaller = ( TH.Type -- Haskell type 35 | , TH.Type -- Haskell-side class type 36 | , QC.Type -- C type 37 | , TH.Name -- Haskell->C marshaller function 38 | , TH.Name) -- C->Haskell marshaller function 39 | 40 | data State 41 | = State 42 | { foreignTable :: Q TH.Exp -- table of foreign labels 43 | , foreignLabels :: [Name] -- list of foreign imported names to populate 'foreignTable' 44 | , headers :: [String] -- imported Objective-C headers 45 | , marshallers :: [CustomMarshaller] -- User defined marshallers 46 | , hoistedObjC_h :: [QC.Definition] -- Objective-C that goes into the .h 47 | , hoistedObjC_m :: [QC.Definition] -- Objective-C that goes into the .m 48 | , hoistedHS :: [TH.Dec] -- Haskell that goes at the end of the module 49 | } 50 | 51 | state :: IORef State 52 | {-# NOINLINE state #-} 53 | state = unsafePerformIO $ 54 | newIORef $ 55 | State 56 | { foreignTable = error "Language.C.Inline.State: internal error: 'foreignTable' undefined" 57 | , foreignLabels = [] 58 | , headers = [] 59 | , marshallers = [] 60 | , hoistedObjC_h = [] 61 | , hoistedObjC_m = [] 62 | , hoistedHS = [] 63 | } 64 | 65 | readState :: (State -> a) -> Q a 66 | readState reader = runIO $ reader <$> readIORef state 67 | 68 | modifyState :: (State -> State) -> Q () 69 | modifyState modify = runIO $ modifyIORef state modify 70 | -- atomic??? 71 | 72 | setForeignTable :: Q TH.Exp -> Q () 73 | setForeignTable e = modifyState (\s -> s {foreignTable = e}) 74 | 75 | stashHeader :: String -> Q () 76 | stashHeader header = modifyState (\s -> s {headers = header : headers s}) 77 | 78 | stashMarshaller :: CustomMarshaller -> Q () 79 | stashMarshaller marshaller = modifyState (\s -> s {marshallers = marshaller : marshallers s}) 80 | 81 | stashObjC_h :: [QC.Definition] -> Q () 82 | stashObjC_h defs = modifyState (\s -> s {hoistedObjC_h = hoistedObjC_h s ++ defs}) 83 | 84 | stashObjC_m :: [QC.Definition] -> Q () 85 | stashObjC_m defs = modifyState (\s -> s {hoistedObjC_m = hoistedObjC_m s ++ defs}) 86 | 87 | stashHS :: [TH.DecQ] -> Q () 88 | stashHS decQs 89 | = do 90 | { decs <- sequence decQs 91 | ; modifyState (\s -> s {hoistedHS = hoistedHS s ++ decs}) 92 | } 93 | 94 | extendJumpTable :: Name -> Q Int 95 | extendJumpTable foreignName 96 | = do 97 | { modifyState (\s -> s {foreignLabels = foreignLabels s ++ [foreignName]}) -- FIXME: *urgh* 98 | ; length <$> readState foreignLabels 99 | } 100 | 101 | getForeignTable :: Q (Q TH.Exp) 102 | getForeignTable = readState foreignTable 103 | 104 | getForeignLabels :: Q [Name] 105 | getForeignLabels = readState foreignLabels 106 | 107 | getHeaders :: Q [String] 108 | getHeaders = reverse <$> readState headers 109 | 110 | getMarshallers :: Q [CustomMarshaller] 111 | getMarshallers = readState marshallers 112 | 113 | lookupMarshaller :: TH.Type -> Q (Maybe CustomMarshaller) 114 | lookupMarshaller ty 115 | = do 116 | { mshs <- getMarshallers 117 | ; case filter (\(hsTy, _, _, _, _) -> hsTy == ty) mshs of 118 | [] -> return Nothing 119 | marshaller:_ -> return $ Just marshaller 120 | } 121 | 122 | 123 | getHoistedObjC :: Q ([QC.Definition], [QC.Definition]) 124 | getHoistedObjC = (,) <$> readState hoistedObjC_h <*> readState hoistedObjC_m 125 | 126 | getHoistedHS :: Q [TH.Dec] 127 | getHoistedHS = readState hoistedHS 128 | -------------------------------------------------------------------------------- /Language/C/Inline/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, GADTs, FlexibleInstances, ViewPatterns, CPP #-} 2 | 3 | -- | 4 | -- Module : Language.C.Inline.TH 5 | -- Copyright : 2014 Manuel M T Chakravarty 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Manuel M T Chakravarty 9 | -- Stability : experimental 10 | -- Portability : non-portable (GHC extensions) 11 | -- 12 | -- This module provides Template Haskell convenience functions. 13 | 14 | module Language.C.Inline.TH ( 15 | -- * Decompose type expressions 16 | headTyConName, headTyConNameOrError, 17 | 18 | -- * Decompose idiomatic declarations 19 | foreignWrapperDatacon, ptrOfForeignPtrWrapper, unwrapForeignPtrWrapper 20 | ) where 21 | 22 | -- standard libraries 23 | import Control.Applicative 24 | import Foreign.Ptr 25 | import Foreign.ForeignPtr 26 | import Language.Haskell.TH as TH 27 | 28 | -- quasi-quotation libraries 29 | import Language.C.Quote as QC 30 | 31 | -- friends 32 | import Language.C.Inline.Error 33 | 34 | 35 | -- |Project the name of the head of a type term if it is a type constructor. 36 | -- 37 | headTyConName :: TH.Type -> Maybe TH.Name 38 | headTyConName ty 39 | = case splitAppTy ty of 40 | (ConT name, _) -> Just name 41 | _ -> Nothing 42 | 43 | -- |Like 'headTyConName', but fail if the head is not a type constructor. 44 | -- 45 | headTyConNameOrError :: QC.Extensions -> TH.Type -> Q TH.Name 46 | headTyConNameOrError lang ty 47 | = case headTyConName ty of 48 | Just name -> return name 49 | Nothing -> reportErrorAndFail lang $ "expected the head of '" ++ show ty ++ "' to be a type constructor" 50 | 51 | -- |Decompose an n-ary type application into its head and arguments. 52 | -- 53 | splitAppTy :: TH.Type -> (TH.Type, [TH.Type]) 54 | splitAppTy = split [] 55 | where 56 | split args (ty `AppT` arg) = split (arg:args) ty 57 | split args (SigT ty _) = split args ty 58 | split args ty = (ty, args) 59 | 60 | -- |Obtain the data constructor of the newtype in an idiomatic 'ForeignPtr' wrapper of the form 61 | -- 62 | -- > newtype Wrapper = Wrapper (ForeignPtr (Wrapper )) 63 | -- 64 | foreignWrapperDatacon :: TH.Type -> Q TH.Exp 65 | foreignWrapperDatacon ty 66 | = do 67 | { (datacon, _) <- decomposeForeignPtrWrapper ty 68 | ; return $ ConE datacon 69 | } 70 | 71 | -- |Unwraps a newtype wrapper around a foreign pointer and turns the 'ForeignPtr' into a 'Ptr'. 72 | -- 73 | ptrOfForeignPtrWrapper :: TH.Type -> Q TH.Type 74 | ptrOfForeignPtrWrapper ty = [t| Ptr $(snd <$> decomposeForeignPtrWrapper ty) |] 75 | 76 | -- |Generate code that unwraps the foreign pointer inside the given foreign pointer wrapper type. 77 | -- 78 | unwrapForeignPtrWrapper :: TH.Type -> Q TH.Exp 79 | unwrapForeignPtrWrapper ty 80 | = do 81 | { (datacon, _) <- decomposeForeignPtrWrapper ty 82 | ; v <- newName "v" 83 | ; [| \e -> $(caseE [| e |] [match (conP datacon [varP v]) (normalB $ varE v) []]) |] 84 | } 85 | 86 | -- |Given a type whose head is a newtype wrapper around a foreign pointer of the form 87 | -- 88 | -- > newtype Wrapper = Wrapper (ForeignPtr (Wrapper )) 89 | -- 90 | -- return the name of the wrapper data constructor and type argument of the 'ForeignPtr', where all '' have been 91 | -- substituted by the arguments in the type application constituting the input type (might be nullary). 92 | -- 93 | decomposeForeignPtrWrapper :: TH.Type -> Q (TH.Name, TH.Type) 94 | decomposeForeignPtrWrapper ty 95 | = do 96 | { let (tycon, args) = splitAppTy ty 97 | ; name <- case tycon of 98 | ConT name -> return name 99 | _ -> 100 | do 101 | { reportErrorAndFail QC.ObjC $ 102 | "expected '" ++ show tycon ++ "' be a type constructor of a 'ForeignPtr' wrapper" 103 | } 104 | 105 | ; reifyUntilFixedPoint args name 106 | } 107 | where 108 | reifyUntilFixedPoint args name 109 | = do 110 | { info <- reify name 111 | ; case info of 112 | TyConI (NewtypeD [] _name tvs (NormalC dataconName [(_strict, ConT fptr `AppT` ptrArg)]) _deriv) 113 | | fptr == ''ForeignPtr 114 | -> return (dataconName, substitute (zip args tvs) ptrArg) 115 | TyConI (TySynD _name tvs (headTyConName -> Just name')) 116 | -> do 117 | { (dcname, type0) <- reifyUntilFixedPoint (drop (length tvs) args) name' 118 | ; return (dcname, substitute (zip args tvs) type0) 119 | } 120 | nonForeign -> 121 | do 122 | { reportErrorAndFail QC.ObjC $ 123 | "expected '" ++ show name ++ "' to refer to a 'ForeignPtr' wrapped into a newtype, but it is " ++ 124 | show (TH.ppr nonForeign) 125 | } } 126 | substitute :: [(TH.Type, TH.TyVarBndr)] -> TH.Type -> TH.Type 127 | substitute subst (ForallT boundTvs cxt' body) 128 | = ForallT boundTvs (substituteCxt subst' cxt') (substitute subst' body) 129 | where 130 | subst' = filter (`notShadowedBy` map theTV boundTvs) subst 131 | -- 132 | (_, tv) `notShadowedBy` boundTvs' = theTV tv `notElem` boundTvs' 133 | -- 134 | theTV (PlainTV tv) = tv 135 | theTV (KindedTV tv _) = tv 136 | substitute subst (t1 `AppT` t2) 137 | = (substitute subst t1) `AppT` (substitute subst t2) 138 | substitute subst (SigT ty' ki) 139 | = SigT (substitute subst ty') ki 140 | substitute subst (VarT tv) 141 | = substituteName subst tv 142 | substitute _subst ty' 143 | = ty' 144 | 145 | substituteCxt subst cxt' = map (substitutePred subst) cxt' 146 | 147 | #if __GLASGOW_HASKELL__ < 709 148 | substitutePred subst (ClassP name tys) = ClassP name (map (substitute subst) tys) 149 | substitutePred subst (EqualP ty1 ty2) = EqualP (substitute subst ty1) (substitute subst ty2) 150 | #else 151 | -- Constraints are just types now. 152 | substitutePred = substitute 153 | #endif 154 | 155 | substituteName [] tv = VarT tv 156 | substituteName ((arg, tv):_args) thisTv 157 | | tv `matches` thisTv = arg 158 | | otherwise = VarT thisTv 159 | 160 | PlainTV name `matches` thisTv = name == thisTv 161 | KindedTV name _ki `matches` thisTv = name == thisTv 162 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | HC = ghc 3 | 4 | LIBDIR := $(shell $(HC) --print-libdir) 5 | CFLAGS = -I$(LIBDIR)/include -I$(LIBDIR)/../../includes 6 | HCFLAGS = # -ddump-splices 7 | LDFLAGS = -package template-haskell -package language-c-quote 8 | 9 | 10 | hs_lib_files := $(shell find Language -name \*.hs) 11 | 12 | inline_tests := $(shell find Test -name \*.hs) 13 | inline_objs := $(patsubst %.hs,%_c.o, $(inline_tests)) 14 | 15 | all : 16 | @ echo $(hs_objs) 17 | 18 | check : testsuite 19 | ./testsuite 20 | 21 | testsuite : tests/dummy tests/testsuite.hs $(inline_objs) 22 | $(HC) tests/testsuite.hs $(inline_objs) $(LDFLAGS) -o $@ 23 | 24 | tests/dummy : tests/dummy.hs 25 | $(HC) --make -c $@ 26 | 27 | clean: 28 | @ rm -f testsuite tests/dummy $(shell find . -name *.o -o -name *.hi -o -name *.dyn_* -o -name *_c.[ch]) 29 | @ cabal clean 30 | 31 | #------------------------------------------------------------------------------- 32 | # Rules 33 | 34 | %.o: %.hs 35 | $(HC) -i. -c $< $(HCFLAGS) 36 | 37 | %_c.c : %.hs 38 | $(HC) -c $< $(HCFLAGS) 39 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Inline C & Objective-C in Haskell 2 | ===================================== 3 | 4 | This library uses Template Haskell and `language-c-quote`, a quasi-quotation library for C-like languages, to provide inline C and Objective-C in Haskell. It extracts the C/Objective-C code automatically, when compiling the Haskell program, and generates marshalling code for common types. The wiki on GitHub details the [motivation](https://github.com/mchakravarty/language-c-inline/wiki/Motivation) for this approach. 5 | 6 | For further motivation, you might like to watch the [YouTube video](http://www.youtube.com/watch?v=pm_WFnWqn20) (matching [slides](https://speakerdeck.com/mchakravarty/foreign-inline-code-in-haskell-haskell-symposium-2014)) of my talk at the Haskell Symposium 2014 (Gothenburg, Sweden), or look at the slides of my YOW! Lambda Jam 2014 talk [Foreign Inline Code in Haskell](https://speakerdeck.com/mchakravarty/foreign-inline-code-in-haskell). 7 | 8 | Building 9 | -------- 10 | 11 | To build the library, just use `cabal install` as usual from the source code directory or by installing from Hackage. 12 | 13 | You may like to have a look at a [minimal example](tests/objc/minimal/Main.hs) of its use, which you can build as follows: 14 | 15 | * Execute `cd tests/objc/minimal; make`. 16 | * Now run the demo executable with `./Minimal`. 17 | 18 | To build the proof of concept example, do the following: 19 | 20 | * Execute `cd tests/objc/concept; make`. 21 | * Now run the demo executable with `./InlineObjC`. 22 | 23 | To build an example class wrapping a Haskell record, do the following: 24 | 25 | * Execute `cd tests/objc/record; make`. 26 | * Now run the demo executable with `./Particle`. 27 | 28 | To build the more complex Haskell interpreter app: 29 | 30 | * Execute `cd tests/objc/app; make`. 31 | * Now `open -a HSApp.app`. 32 | 33 | Status 34 | ====== 35 | 36 | **Update:** For various reasons (mostly lack of time on my side), all my recent changes have been on the `release/0.7` branch, which also hosts the version that you can find on Hackage. That version has been used in production. It is the glue between the Haskell and Swift part of [Haskell for Mac](http://haskellformac.com). For a larger open-source example of using `language-c-inline`, see [HaskellSpriteKit](https://github.com/mchakravarty/HaskellSpriteKit). 37 | 38 | Unfortunately, I haven't been able to find the time to merge all the improvements on `release/0.7` back into `master`. 39 | 40 | The library is in beta and focuses mostly on Objective-C. Automatic marshalling support is still somewhat limited. However, it is quite easy to add more types, and I do welcome pull request! 41 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /Test/PosixC.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, QuasiQuotes #-} 2 | 3 | module Test.PosixC 4 | ( cPlusOne 5 | , cStringCompare 6 | , cGetString 7 | , cPassString 8 | 9 | , cSin 10 | , cSinF 11 | , cInvertSin 12 | , cInvertSinF 13 | 14 | -- The module initialisation function. 15 | , posixCInit 16 | ) where 17 | 18 | import Control.Applicative 19 | import Language.C.Quote.C 20 | import Language.C.Inline.C 21 | 22 | import Language.Haskell.TH 23 | 24 | c_import ["", "", ""] 25 | 26 | cPlusOne :: Int -> IO Int 27 | cPlusOne i = $(c [ 'i :> ''Int ] (''Int <: [cexp| (i + 1) |])) 28 | 29 | cStringCompare :: String -> String -> IO Ordering 30 | cStringCompare s1 s2 = 31 | compareInt <$> $(c [ 's1 :> ''String, 's2 :> ''String ] (''Int <: [cexp| strcmp (s1, s2) |])) 32 | where 33 | compareInt i 34 | | i > 0 = GT 35 | | i < 0 = LT 36 | | otherwise = EQ 37 | 38 | 39 | cGetString :: IO String 40 | cGetString = $(c [] (''String <: [cexp| "Hello Haskell" |])) 41 | 42 | cPassString :: String -> IO String 43 | cPassString msg = $(c [ 'msg :> ''String ] (''String <: [cexp| msg |])) 44 | 45 | cSin :: Double -> IO Double 46 | cSin x = $(c [ 'x :> ''Double ] (''Double <: [cexp| sin(x) |])) 47 | 48 | cSinF :: Float -> IO Float 49 | cSinF x = $(c [ 'x :> ''Float ] (''Float <: [cexp| sinf(x) |])) 50 | 51 | cInvertSin :: Double -> IO Double 52 | cInvertSin x = $(c [ 'x :> ''Double ] (''Double <: [cexp| sin(asin(x)) |])) 53 | 54 | cInvertSinF :: Float -> IO Float 55 | cInvertSinF x = $(c [ 'x :> ''Float ] (''Float <: [cexp| sinf(asinf(x)) |])) 56 | 57 | c_emit 58 | 59 | posixCInit :: IO () 60 | posixCInit = c_initialise 61 | -------------------------------------------------------------------------------- /language-c-inline.cabal: -------------------------------------------------------------------------------- 1 | Name: language-c-inline 2 | Version: 0.8.0.0 3 | Cabal-version: >= 1.9.2 4 | Tested-with: GHC == 7.6.3, GHC == 7.8.2 5 | Build-type: Simple 6 | 7 | Synopsis: Inline C & Objective-C code in Haskell for language interoperability 8 | Description: This library provides inline C & Objective-C code using GHC's support for 9 | quasi-quotation. In particular, it enables the use of foreign libraries 10 | without a dedicated bridge or binding. Here is a tiny example: 11 | . 12 | > nslog :: String -> IO () 13 | > nslog msg = $(objc ['msg :> ''String] (void [cexp| NSLog(@"Here is a message from Haskell: %@", msg) |])) 14 | . 15 | For more information, see . 16 | . 17 | Known bugs: 18 | . 19 | * New in 0.8.0: Support for ISO C, courtesy Erik de Castro Lopo 20 | . 21 | * New in 0.7.6: (1) Record marshalling; (2) foreign pointer-class marshalling; (3) custom type 22 | marshallers. Generated _objc.m files now always include "HsFFI.h" (as the tool can generate type names 23 | declared in that header). Marshals 'Bool' as 'BOOL'. Marshal 'Int' and 'Word' to 'NSInteger' and 24 | 'NSUInteger', respectively. 25 | . 26 | * New in 0.6.0: Introduction of explicit marshalling hints (for more flexibility and support of 27 | GHC 7.8's untyped Template Haskell quotations) 28 | . 29 | * New in 0.5.0: Marshalling of numeric types 30 | . 31 | * New in 0.4.0: Maybe types are marshalled as pointers that may be nil & bug fixes. 32 | . 33 | * New in 0.3.0: Boxed Haskell types without a dedicated type mapping are marshalled using stable 34 | pointers. 35 | . 36 | * New in 0.2.0: Support for multiple free variables in one inline expression as well 37 | as for inline code returning 'void'. 38 | . 39 | * New in 0.1.0: We are just getting started! This is just a ROUGH AND 40 | HIGHLY EXPERIMENTAL PROTOTYPE. 41 | License: BSD3 42 | License-file: LICENSE 43 | Author: Manuel M T Chakravarty 44 | Maintainer: Manuel M T Chakravarty 45 | Homepage: https://github.com/mchakravarty/language-c-inline/ 46 | Bug-reports: https://github.com/mchakravarty/language-c-inline/issues 47 | 48 | Category: Language, Foreign 49 | Stability: Experimental 50 | 51 | Extra-source-files: README.md 52 | tests/objc/app/App.hs 53 | tests/objc/app/AppDelegate.hs 54 | tests/objc/app/Interpreter.hs 55 | tests/objc/app/Main.hs 56 | tests/objc/app/Makefile 57 | tests/objc/app/Readme.md 58 | tests/objc/app/HSApp.app/Contents/Info.plist 59 | tests/objc/app/HSApp.app/Contents/MacOS/.gitkeep 60 | tests/objc/app/HSApp.app/Contents/Resources/en.lproj/Credits.rtf 61 | tests/objc/app/HSApp.app/Contents/Resources/en.lproj/InfoPlist.strings 62 | tests/objc/app/HSApp.app/Contents/Resources/en.lproj/MainMenu.nib 63 | tests/objc/concept/Makefile 64 | tests/objc/minimal/Makefile 65 | tests/objc/minimal/Main.hs 66 | tests/objc/record/Makefile 67 | tests/objc/record/Main.hs 68 | tests/objc/record/Particle.hs 69 | 70 | Source-repository head 71 | Type: git 72 | Location: git://github.com/mchakravarty/language-c-inline.git 73 | 74 | Flag ManualTests 75 | Description: Enables tests that require manual intervention. 76 | Default: False 77 | 78 | Library 79 | Build-depends: array, 80 | base >= 4.0 && < 5, 81 | containers >= 0.4, 82 | filepath >= 1.2, 83 | language-c-quote >= 0.8, 84 | mainland-pretty >= 0.2.5, 85 | template-haskell 86 | 87 | Ghc-Options: -O2 -Wall -fwarn-tabs -fno-warn-incomplete-patterns 88 | 89 | Exposed-modules: Language.C.Inline.C 90 | Language.C.Inline.ObjC 91 | 92 | Other-modules: Language.C.Inline.Error 93 | Language.C.Inline.Hint 94 | Language.C.Inline.State 95 | Language.C.Inline.TH 96 | Language.C.Inline.C.Hint 97 | Language.C.Inline.C.Marshal 98 | Language.C.Inline.ObjC.Hint 99 | Language.C.Inline.ObjC.Marshal 100 | 101 | Extensions: TemplateHaskell, QuasiQuotes 102 | 103 | -- Doesn't work!!! Use the Makefile in the tests/ instead. (How can we get cabal to compile & link the generated ObjC files?) 104 | Test-Suite concept 105 | if flag(ManualTests) 106 | Buildable: True 107 | else 108 | Buildable: False 109 | 110 | Build-depends: base >= 4.0 && < 5, 111 | language-c-quote, 112 | language-c-inline 113 | 114 | Frameworks: Foundation 115 | 116 | Type: exitcode-stdio-1.0 117 | 118 | Hs-source-dirs: tests/objc/concept 119 | 120 | Main-is: MainInlineObjC.hs 121 | 122 | Other-modules: TestInlineObjC 123 | -------------------------------------------------------------------------------- /tests/dummy.hs: -------------------------------------------------------------------------------- 1 | 2 | -- This program does nothing. Its only here to force the building of the 3 | -- library object files for use with the testsuite. 4 | 5 | import Language.C.Quote.C () 6 | import Language.C.Inline.C () 7 | import Language.Haskell.TH () 8 | 9 | main :: IO () 10 | main = putStrLn "Dummy program." 11 | -------------------------------------------------------------------------------- /tests/objc/app/App.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, QuasiQuotes #-} 2 | 3 | -- HSApp: a simple Cocoa app in Haskell 4 | -- 5 | -- Main application module entering AppKit's application framework 6 | 7 | module App (main, objc_initialise) where 8 | 9 | import Language.C.Quote.ObjC 10 | import Language.C.Inline.ObjC 11 | 12 | objc_import [""] 13 | 14 | 15 | main :: IO () 16 | main = $(objc [] $ 17 | void [cexp| NSApplicationMain (0, NULL) |]) 18 | -- 'NSApplicationMain' ignores its argc and argv arguments anyway 19 | 20 | objc_emit 21 | -------------------------------------------------------------------------------- /tests/objc/app/AppDelegate.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, QuasiQuotes #-} 2 | 3 | -- HSApp: a simple Cocoa app in Haskell 4 | -- 5 | -- Application delegate object, abused as a view controller 6 | 7 | module AppDelegate (objc_initialise) where 8 | 9 | -- language-c-inline 10 | import Language.C.Quote.ObjC 11 | import Language.C.Inline.ObjC 12 | 13 | -- friends 14 | import Interpreter 15 | 16 | objc_import [""] 17 | 18 | 19 | -- Haskell code used from Objective-C. 20 | 21 | launchMsg :: String 22 | launchMsg = "HSApp did finish launching!" 23 | 24 | evalExpr :: Session -> String -> IO String 25 | evalExpr _session "" 26 | = return "" 27 | evalExpr session input@(':' : withCommand) 28 | = case break (== ' ') withCommand of 29 | ("type", expr) -> do 30 | { result <- typeOf session expr 31 | ; return $ formatResult input result 32 | } 33 | (command, _) -> return $ "Haskell> " ++ input ++ "\nUnknown command '" ++ command ++ "'\n" 34 | evalExpr session expr 35 | = do 36 | { result <- eval session expr 37 | ; return $ formatResult expr result 38 | } 39 | where 40 | 41 | loadModule :: Session -> String -> IO String 42 | loadModule session mname 43 | = do 44 | { result <- load session mname 45 | ; return $ formatResult "" result 46 | } 47 | 48 | formatResult :: String -> Result -> String 49 | formatResult input result = (if null input then "" else "Haskell> " ++ input ++ "\n") ++ showResult result ++ "\n" 50 | where 51 | showResult (Result res) = res 52 | showResult (Error err) = "ERROR: " ++ err 53 | 54 | 55 | objc_interface [cunit| 56 | 57 | @interface AppDelegate : NSResponder 58 | 59 | // IBOutlets 60 | @property (weak, nonatomic) typename NSWindow *window; 61 | @property (weak, nonatomic) typename NSScrollView *scrollView; 62 | @property (weak, nonatomic) typename NSTextField *textField; 63 | 64 | @end 65 | |] 66 | 67 | 68 | objc_implementation [Typed 'launchMsg, Typed 'start, Typed 'evalExpr, Typed 'loadModule] [cunit| 69 | 70 | @interface AppDelegate () 71 | 72 | // The NSTextView in the UI. 73 | @property (nonatomic) typename NSTextView *textView; 74 | 75 | // Reference to the interpreter session in Haskell land. 76 | @property (assign) typename HsStablePtr interpreterSession; 77 | 78 | - (void)appendOutput:(typename NSString *)text; 79 | 80 | @end 81 | 82 | @implementation AppDelegate 83 | 84 | - (void)applicationDidFinishLaunching:(typename NSNotification *)aNotification 85 | { 86 | [[self.textField cell] setPlaceholderString:@"Enter an expression, or use the :type command"]; 87 | self.textView = self.scrollView.documentView; 88 | self.interpreterSession = start(); 89 | NSLog(@"%@", launchMsg()); 90 | } 91 | 92 | // IBAction 93 | - (void)textFieldDidSend:(typename NSTextField *)sender 94 | { 95 | [self appendOutput:evalExpr(self.interpreterSession, [sender stringValue])]; 96 | [sender setStringValue:@""]; 97 | } 98 | 99 | - (void)appendOutput:(typename NSString *)text 100 | { 101 | typename NSFont *menlo13 = [NSFont fontWithName:@"Menlo-Regular" size:13]; 102 | typename NSAttributedString *attrText = [[NSAttributedString alloc] initWithString:text 103 | attributes:@{ NSFontAttributeName : menlo13 }]; 104 | [self.textView.textStorage appendAttributedString:attrText]; 105 | [self.textView scrollRangeToVisible:NSMakeRange([self.textView.textStorage length], 0)]; 106 | } 107 | 108 | - (void)openDocument:(id)sender 109 | { 110 | typename NSOpenPanel* panel = [NSOpenPanel openPanel]; 111 | [panel setMessage:@"Select a Haskell module to load."]; 112 | [panel setAllowedFileTypes:@[@"hs", @"lhs"]]; 113 | [panel beginSheetModalForWindow:self.window completionHandler:^(typename NSInteger result){ 114 | if (result == NSFileHandlingPanelOKButton) { 115 | 116 | typename NSArray* urls = [panel URLs]; 117 | [self appendOutput:loadModule(self.interpreterSession, [[urls firstObject] path])]; 118 | 119 | } 120 | 121 | }]; 122 | } 123 | 124 | @end 125 | |] 126 | 127 | 128 | objc_emit 129 | -------------------------------------------------------------------------------- /tests/objc/app/HSApp-xcode-prj/HSApp.xcodeproj/project.pbxproj: -------------------------------------------------------------------------------- 1 | // !$*UTF8*$! 2 | { 3 | archiveVersion = 1; 4 | classes = { 5 | }; 6 | objectVersion = 46; 7 | objects = { 8 | 9 | /* Begin PBXBuildFile section */ 10 | E7EF1467171924E300190C3D /* Cocoa.framework in Frameworks */ = {isa = PBXBuildFile; fileRef = E7EF1466171924E300190C3D /* Cocoa.framework */; }; 11 | E7EF1471171924E300190C3D /* InfoPlist.strings in Resources */ = {isa = PBXBuildFile; fileRef = E7EF146F171924E300190C3D /* InfoPlist.strings */; }; 12 | E7EF1473171924E300190C3D /* main.m in Sources */ = {isa = PBXBuildFile; fileRef = E7EF1472171924E300190C3D /* main.m */; }; 13 | E7EF1477171924E300190C3D /* Credits.rtf in Resources */ = {isa = PBXBuildFile; fileRef = E7EF1475171924E300190C3D /* Credits.rtf */; }; 14 | E7EF147A171924E300190C3D /* AppDelegate.m in Sources */ = {isa = PBXBuildFile; fileRef = E7EF1479171924E300190C3D /* AppDelegate.m */; }; 15 | E7EF147D171924E300190C3D /* MainMenu.xib in Resources */ = {isa = PBXBuildFile; fileRef = E7EF147B171924E300190C3D /* MainMenu.xib */; }; 16 | /* End PBXBuildFile section */ 17 | 18 | /* Begin PBXFileReference section */ 19 | E7EF1463171924E300190C3D /* HSApp.app */ = {isa = PBXFileReference; explicitFileType = wrapper.application; includeInIndex = 0; path = HSApp.app; sourceTree = BUILT_PRODUCTS_DIR; }; 20 | E7EF1466171924E300190C3D /* Cocoa.framework */ = {isa = PBXFileReference; lastKnownFileType = wrapper.framework; name = Cocoa.framework; path = System/Library/Frameworks/Cocoa.framework; sourceTree = SDKROOT; }; 21 | E7EF1469171924E300190C3D /* AppKit.framework */ = {isa = PBXFileReference; lastKnownFileType = wrapper.framework; name = AppKit.framework; path = System/Library/Frameworks/AppKit.framework; sourceTree = SDKROOT; }; 22 | E7EF146A171924E300190C3D /* CoreData.framework */ = {isa = PBXFileReference; lastKnownFileType = wrapper.framework; name = CoreData.framework; path = System/Library/Frameworks/CoreData.framework; sourceTree = SDKROOT; }; 23 | E7EF146B171924E300190C3D /* Foundation.framework */ = {isa = PBXFileReference; lastKnownFileType = wrapper.framework; name = Foundation.framework; path = System/Library/Frameworks/Foundation.framework; sourceTree = SDKROOT; }; 24 | E7EF146E171924E300190C3D /* HSApp-Info.plist */ = {isa = PBXFileReference; lastKnownFileType = text.plist.xml; path = "HSApp-Info.plist"; sourceTree = ""; }; 25 | E7EF1470171924E300190C3D /* en */ = {isa = PBXFileReference; lastKnownFileType = text.plist.strings; name = en; path = en.lproj/InfoPlist.strings; sourceTree = ""; }; 26 | E7EF1472171924E300190C3D /* main.m */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.c.objc; path = main.m; sourceTree = ""; }; 27 | E7EF1474171924E300190C3D /* HSApp-Prefix.pch */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.c.h; path = "HSApp-Prefix.pch"; sourceTree = ""; }; 28 | E7EF1476171924E300190C3D /* en */ = {isa = PBXFileReference; lastKnownFileType = text.rtf; name = en; path = en.lproj/Credits.rtf; sourceTree = ""; }; 29 | E7EF1478171924E300190C3D /* AppDelegate.h */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.c.h; path = AppDelegate.h; sourceTree = ""; }; 30 | E7EF1479171924E300190C3D /* AppDelegate.m */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.c.objc; path = AppDelegate.m; sourceTree = ""; }; 31 | E7EF147C171924E300190C3D /* en */ = {isa = PBXFileReference; lastKnownFileType = file.xib; name = en; path = en.lproj/MainMenu.xib; sourceTree = ""; }; 32 | /* End PBXFileReference section */ 33 | 34 | /* Begin PBXFrameworksBuildPhase section */ 35 | E7EF1460171924E300190C3D /* Frameworks */ = { 36 | isa = PBXFrameworksBuildPhase; 37 | buildActionMask = 2147483647; 38 | files = ( 39 | E7EF1467171924E300190C3D /* Cocoa.framework in Frameworks */, 40 | ); 41 | runOnlyForDeploymentPostprocessing = 0; 42 | }; 43 | /* End PBXFrameworksBuildPhase section */ 44 | 45 | /* Begin PBXGroup section */ 46 | E7EF145A171924E300190C3D = { 47 | isa = PBXGroup; 48 | children = ( 49 | E7EF146C171924E300190C3D /* HSApp */, 50 | E7EF1465171924E300190C3D /* Frameworks */, 51 | E7EF1464171924E300190C3D /* Products */, 52 | ); 53 | sourceTree = ""; 54 | }; 55 | E7EF1464171924E300190C3D /* Products */ = { 56 | isa = PBXGroup; 57 | children = ( 58 | E7EF1463171924E300190C3D /* HSApp.app */, 59 | ); 60 | name = Products; 61 | sourceTree = ""; 62 | }; 63 | E7EF1465171924E300190C3D /* Frameworks */ = { 64 | isa = PBXGroup; 65 | children = ( 66 | E7EF1466171924E300190C3D /* Cocoa.framework */, 67 | E7EF1468171924E300190C3D /* Other Frameworks */, 68 | ); 69 | name = Frameworks; 70 | sourceTree = ""; 71 | }; 72 | E7EF1468171924E300190C3D /* Other Frameworks */ = { 73 | isa = PBXGroup; 74 | children = ( 75 | E7EF1469171924E300190C3D /* AppKit.framework */, 76 | E7EF146A171924E300190C3D /* CoreData.framework */, 77 | E7EF146B171924E300190C3D /* Foundation.framework */, 78 | ); 79 | name = "Other Frameworks"; 80 | sourceTree = ""; 81 | }; 82 | E7EF146C171924E300190C3D /* HSApp */ = { 83 | isa = PBXGroup; 84 | children = ( 85 | E7EF1478171924E300190C3D /* AppDelegate.h */, 86 | E7EF1479171924E300190C3D /* AppDelegate.m */, 87 | E7EF147B171924E300190C3D /* MainMenu.xib */, 88 | E7EF146D171924E300190C3D /* Supporting Files */, 89 | ); 90 | path = HSApp; 91 | sourceTree = ""; 92 | }; 93 | E7EF146D171924E300190C3D /* Supporting Files */ = { 94 | isa = PBXGroup; 95 | children = ( 96 | E7EF146E171924E300190C3D /* HSApp-Info.plist */, 97 | E7EF146F171924E300190C3D /* InfoPlist.strings */, 98 | E7EF1472171924E300190C3D /* main.m */, 99 | E7EF1474171924E300190C3D /* HSApp-Prefix.pch */, 100 | E7EF1475171924E300190C3D /* Credits.rtf */, 101 | ); 102 | name = "Supporting Files"; 103 | sourceTree = ""; 104 | }; 105 | /* End PBXGroup section */ 106 | 107 | /* Begin PBXNativeTarget section */ 108 | E7EF1462171924E300190C3D /* HSApp */ = { 109 | isa = PBXNativeTarget; 110 | buildConfigurationList = E7EF1480171924E300190C3D /* Build configuration list for PBXNativeTarget "HSApp" */; 111 | buildPhases = ( 112 | E7EF145F171924E300190C3D /* Sources */, 113 | E7EF1460171924E300190C3D /* Frameworks */, 114 | E7EF1461171924E300190C3D /* Resources */, 115 | ); 116 | buildRules = ( 117 | ); 118 | dependencies = ( 119 | ); 120 | name = HSApp; 121 | productName = HSApp; 122 | productReference = E7EF1463171924E300190C3D /* HSApp.app */; 123 | productType = "com.apple.product-type.application"; 124 | }; 125 | /* End PBXNativeTarget section */ 126 | 127 | /* Begin PBXProject section */ 128 | E7EF145B171924E300190C3D /* Project object */ = { 129 | isa = PBXProject; 130 | attributes = { 131 | CLASSPREFIX = HSA; 132 | LastUpgradeCheck = 0460; 133 | ORGANIZATIONNAME = "Manuel M T Chakravarty"; 134 | }; 135 | buildConfigurationList = E7EF145E171924E300190C3D /* Build configuration list for PBXProject "HSApp" */; 136 | compatibilityVersion = "Xcode 3.2"; 137 | developmentRegion = English; 138 | hasScannedForEncodings = 0; 139 | knownRegions = ( 140 | en, 141 | ); 142 | mainGroup = E7EF145A171924E300190C3D; 143 | productRefGroup = E7EF1464171924E300190C3D /* Products */; 144 | projectDirPath = ""; 145 | projectRoot = ""; 146 | targets = ( 147 | E7EF1462171924E300190C3D /* HSApp */, 148 | ); 149 | }; 150 | /* End PBXProject section */ 151 | 152 | /* Begin PBXResourcesBuildPhase section */ 153 | E7EF1461171924E300190C3D /* Resources */ = { 154 | isa = PBXResourcesBuildPhase; 155 | buildActionMask = 2147483647; 156 | files = ( 157 | E7EF1471171924E300190C3D /* InfoPlist.strings in Resources */, 158 | E7EF1477171924E300190C3D /* Credits.rtf in Resources */, 159 | E7EF147D171924E300190C3D /* MainMenu.xib in Resources */, 160 | ); 161 | runOnlyForDeploymentPostprocessing = 0; 162 | }; 163 | /* End PBXResourcesBuildPhase section */ 164 | 165 | /* Begin PBXSourcesBuildPhase section */ 166 | E7EF145F171924E300190C3D /* Sources */ = { 167 | isa = PBXSourcesBuildPhase; 168 | buildActionMask = 2147483647; 169 | files = ( 170 | E7EF1473171924E300190C3D /* main.m in Sources */, 171 | E7EF147A171924E300190C3D /* AppDelegate.m in Sources */, 172 | ); 173 | runOnlyForDeploymentPostprocessing = 0; 174 | }; 175 | /* End PBXSourcesBuildPhase section */ 176 | 177 | /* Begin PBXVariantGroup section */ 178 | E7EF146F171924E300190C3D /* InfoPlist.strings */ = { 179 | isa = PBXVariantGroup; 180 | children = ( 181 | E7EF1470171924E300190C3D /* en */, 182 | ); 183 | name = InfoPlist.strings; 184 | sourceTree = ""; 185 | }; 186 | E7EF1475171924E300190C3D /* Credits.rtf */ = { 187 | isa = PBXVariantGroup; 188 | children = ( 189 | E7EF1476171924E300190C3D /* en */, 190 | ); 191 | name = Credits.rtf; 192 | sourceTree = ""; 193 | }; 194 | E7EF147B171924E300190C3D /* MainMenu.xib */ = { 195 | isa = PBXVariantGroup; 196 | children = ( 197 | E7EF147C171924E300190C3D /* en */, 198 | ); 199 | name = MainMenu.xib; 200 | sourceTree = ""; 201 | }; 202 | /* End PBXVariantGroup section */ 203 | 204 | /* Begin XCBuildConfiguration section */ 205 | E7EF147E171924E300190C3D /* Debug */ = { 206 | isa = XCBuildConfiguration; 207 | buildSettings = { 208 | ALWAYS_SEARCH_USER_PATHS = NO; 209 | ARCHS = "$(ARCHS_STANDARD_64_BIT)"; 210 | CLANG_CXX_LANGUAGE_STANDARD = "gnu++0x"; 211 | CLANG_CXX_LIBRARY = "libc++"; 212 | CLANG_ENABLE_OBJC_ARC = YES; 213 | CLANG_WARN_CONSTANT_CONVERSION = YES; 214 | CLANG_WARN_EMPTY_BODY = YES; 215 | CLANG_WARN_ENUM_CONVERSION = YES; 216 | CLANG_WARN_INT_CONVERSION = YES; 217 | CLANG_WARN__DUPLICATE_METHOD_MATCH = YES; 218 | COPY_PHASE_STRIP = NO; 219 | GCC_C_LANGUAGE_STANDARD = gnu99; 220 | GCC_DYNAMIC_NO_PIC = NO; 221 | GCC_ENABLE_OBJC_EXCEPTIONS = YES; 222 | GCC_OPTIMIZATION_LEVEL = 0; 223 | GCC_PREPROCESSOR_DEFINITIONS = ( 224 | "DEBUG=1", 225 | "$(inherited)", 226 | ); 227 | GCC_SYMBOLS_PRIVATE_EXTERN = NO; 228 | GCC_WARN_64_TO_32_BIT_CONVERSION = YES; 229 | GCC_WARN_ABOUT_RETURN_TYPE = YES; 230 | GCC_WARN_UNINITIALIZED_AUTOS = YES; 231 | GCC_WARN_UNUSED_VARIABLE = YES; 232 | MACOSX_DEPLOYMENT_TARGET = 10.8; 233 | ONLY_ACTIVE_ARCH = YES; 234 | SDKROOT = macosx; 235 | }; 236 | name = Debug; 237 | }; 238 | E7EF147F171924E300190C3D /* Release */ = { 239 | isa = XCBuildConfiguration; 240 | buildSettings = { 241 | ALWAYS_SEARCH_USER_PATHS = NO; 242 | ARCHS = "$(ARCHS_STANDARD_64_BIT)"; 243 | CLANG_CXX_LANGUAGE_STANDARD = "gnu++0x"; 244 | CLANG_CXX_LIBRARY = "libc++"; 245 | CLANG_ENABLE_OBJC_ARC = YES; 246 | CLANG_WARN_CONSTANT_CONVERSION = YES; 247 | CLANG_WARN_EMPTY_BODY = YES; 248 | CLANG_WARN_ENUM_CONVERSION = YES; 249 | CLANG_WARN_INT_CONVERSION = YES; 250 | CLANG_WARN__DUPLICATE_METHOD_MATCH = YES; 251 | COPY_PHASE_STRIP = YES; 252 | DEBUG_INFORMATION_FORMAT = "dwarf-with-dsym"; 253 | GCC_C_LANGUAGE_STANDARD = gnu99; 254 | GCC_ENABLE_OBJC_EXCEPTIONS = YES; 255 | GCC_WARN_64_TO_32_BIT_CONVERSION = YES; 256 | GCC_WARN_ABOUT_RETURN_TYPE = YES; 257 | GCC_WARN_UNINITIALIZED_AUTOS = YES; 258 | GCC_WARN_UNUSED_VARIABLE = YES; 259 | MACOSX_DEPLOYMENT_TARGET = 10.8; 260 | SDKROOT = macosx; 261 | }; 262 | name = Release; 263 | }; 264 | E7EF1481171924E300190C3D /* Debug */ = { 265 | isa = XCBuildConfiguration; 266 | buildSettings = { 267 | COMBINE_HIDPI_IMAGES = YES; 268 | GCC_PRECOMPILE_PREFIX_HEADER = YES; 269 | GCC_PREFIX_HEADER = "HSApp/HSApp-Prefix.pch"; 270 | INFOPLIST_FILE = "HSApp/HSApp-Info.plist"; 271 | PRODUCT_NAME = "$(TARGET_NAME)"; 272 | WRAPPER_EXTENSION = app; 273 | }; 274 | name = Debug; 275 | }; 276 | E7EF1482171924E300190C3D /* Release */ = { 277 | isa = XCBuildConfiguration; 278 | buildSettings = { 279 | COMBINE_HIDPI_IMAGES = YES; 280 | GCC_PRECOMPILE_PREFIX_HEADER = YES; 281 | GCC_PREFIX_HEADER = "HSApp/HSApp-Prefix.pch"; 282 | INFOPLIST_FILE = "HSApp/HSApp-Info.plist"; 283 | PRODUCT_NAME = "$(TARGET_NAME)"; 284 | WRAPPER_EXTENSION = app; 285 | }; 286 | name = Release; 287 | }; 288 | /* End XCBuildConfiguration section */ 289 | 290 | /* Begin XCConfigurationList section */ 291 | E7EF145E171924E300190C3D /* Build configuration list for PBXProject "HSApp" */ = { 292 | isa = XCConfigurationList; 293 | buildConfigurations = ( 294 | E7EF147E171924E300190C3D /* Debug */, 295 | E7EF147F171924E300190C3D /* Release */, 296 | ); 297 | defaultConfigurationIsVisible = 0; 298 | defaultConfigurationName = Release; 299 | }; 300 | E7EF1480171924E300190C3D /* Build configuration list for PBXNativeTarget "HSApp" */ = { 301 | isa = XCConfigurationList; 302 | buildConfigurations = ( 303 | E7EF1481171924E300190C3D /* Debug */, 304 | E7EF1482171924E300190C3D /* Release */, 305 | ); 306 | defaultConfigurationIsVisible = 0; 307 | defaultConfigurationName = Release; 308 | }; 309 | /* End XCConfigurationList section */ 310 | }; 311 | rootObject = E7EF145B171924E300190C3D /* Project object */; 312 | } 313 | -------------------------------------------------------------------------------- /tests/objc/app/HSApp-xcode-prj/HSApp/AppDelegate.h: -------------------------------------------------------------------------------- 1 | // 2 | // AppDelegate.h 3 | // HSApp 4 | // 5 | // Created by Manuel M T Chakravarty on 13/04/13. 6 | // Copyright (c) 2013 Manuel M T Chakravarty. All rights reserved. 7 | // 8 | 9 | #import 10 | 11 | @interface AppDelegate : NSObject 12 | 13 | @property (weak, nonatomic) IBOutlet NSWindow *window; 14 | @property (weak, nonatomic) IBOutlet NSScrollView *scrollView; 15 | @property (weak, nonatomic) IBOutlet NSTextField *textField; 16 | 17 | @end 18 | -------------------------------------------------------------------------------- /tests/objc/app/HSApp-xcode-prj/HSApp/AppDelegate.m: -------------------------------------------------------------------------------- 1 | // 2 | // AppDelegate.m 3 | // HSApp 4 | // 5 | // Created by Manuel M T Chakravarty on 13/04/13. 6 | // Copyright (c) 2013 Manuel M T Chakravarty. All rights reserved. 7 | // 8 | 9 | #import "AppDelegate.h" 10 | 11 | 12 | @interface AppDelegate () 13 | 14 | @property NSTextView *textView; 15 | 16 | - (void)appendOutput:(NSString *)text; 17 | 18 | @end 19 | 20 | 21 | @implementation AppDelegate 22 | 23 | - (void)applicationDidFinishLaunching:(NSNotification *)aNotification 24 | { 25 | self.textView = self.scrollView.documentView; 26 | [self appendOutput:@"Hello Wordl!"]; 27 | NSLog(@"I did launch!"); 28 | } 29 | 30 | - (IBAction)textFieldDidSend:(NSTextField *)sender 31 | { 32 | [self appendOutput:[sender stringValue]]; 33 | [sender setStringValue:@""]; 34 | } 35 | 36 | - (void)appendOutput:(NSString *)text 37 | { 38 | NSAttributedString *attrText = [[NSAttributedString alloc] initWithString:text]; 39 | [self.textView.textStorage appendAttributedString:attrText]; 40 | } 41 | 42 | @end 43 | -------------------------------------------------------------------------------- /tests/objc/app/HSApp-xcode-prj/HSApp/HSApp-Info.plist: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | CFBundleDevelopmentRegion 6 | en 7 | CFBundleExecutable 8 | ${EXECUTABLE_NAME} 9 | CFBundleIconFile 10 | 11 | CFBundleIdentifier 12 | org.justtesting.${PRODUCT_NAME:rfc1034identifier} 13 | CFBundleInfoDictionaryVersion 14 | 6.0 15 | CFBundleName 16 | ${PRODUCT_NAME} 17 | CFBundlePackageType 18 | APPL 19 | CFBundleShortVersionString 20 | 1.0 21 | CFBundleSignature 22 | ???? 23 | CFBundleVersion 24 | 1 25 | LSApplicationCategoryType 26 | public.app-category.developer-tools 27 | LSMinimumSystemVersion 28 | ${MACOSX_DEPLOYMENT_TARGET} 29 | NSHumanReadableCopyright 30 | Copyright © 2013 Manuel M T Chakravarty. All rights reserved. 31 | NSMainNibFile 32 | MainMenu 33 | NSPrincipalClass 34 | NSApplication 35 | 36 | 37 | -------------------------------------------------------------------------------- /tests/objc/app/HSApp-xcode-prj/HSApp/HSApp-Prefix.pch: -------------------------------------------------------------------------------- 1 | // 2 | // Prefix header for all source files of the 'HSApp' target in the 'HSApp' project 3 | // 4 | 5 | #ifdef __OBJC__ 6 | #import 7 | #endif 8 | -------------------------------------------------------------------------------- /tests/objc/app/HSApp-xcode-prj/HSApp/en.lproj/Credits.rtf: -------------------------------------------------------------------------------- 1 | {\rtf0\ansi{\fonttbl\f0\fswiss Helvetica;} 2 | {\colortbl;\red255\green255\blue255;} 3 | \paperw9840\paperh8400 4 | \pard\tx560\tx1120\tx1680\tx2240\tx2800\tx3360\tx3920\tx4480\tx5040\tx5600\tx6160\tx6720\ql\qnatural 5 | 6 | \f0\b\fs24 \cf0 Engineering: 7 | \b0 \ 8 | Some people\ 9 | \ 10 | 11 | \b Human Interface Design: 12 | \b0 \ 13 | Some other people\ 14 | \ 15 | 16 | \b Testing: 17 | \b0 \ 18 | Hopefully not nobody\ 19 | \ 20 | 21 | \b Documentation: 22 | \b0 \ 23 | Whoever\ 24 | \ 25 | 26 | \b With special thanks to: 27 | \b0 \ 28 | Mom\ 29 | } 30 | -------------------------------------------------------------------------------- /tests/objc/app/HSApp-xcode-prj/HSApp/en.lproj/InfoPlist.strings: -------------------------------------------------------------------------------- 1 | /* Localized versions of Info.plist keys */ 2 | 3 | -------------------------------------------------------------------------------- /tests/objc/app/HSApp-xcode-prj/HSApp/en.lproj/MainMenu.xib: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 | 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107 | 108 | 109 | 110 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | 119 | 120 | 121 | 122 | 123 | 124 | 125 | 126 | 127 | 128 | 129 | 130 | 131 | 132 | 133 | 134 | 135 | 136 | 137 | 138 | 139 | 140 | 141 | 142 | 143 | 144 | 145 | 146 | 147 | 148 | 149 | 150 | 151 | 152 | 153 | 154 | 155 | 156 | 157 | 158 | 159 | 160 | 161 | 162 | 163 | 164 | 165 | 166 | 167 | 168 | 169 | 170 | 171 | 172 | 173 | 174 | 175 | 176 | 177 | 178 | 179 | 180 | 181 | 182 | 183 | 184 | 185 | 186 | 187 | 188 | 189 | 190 | 191 | 192 | 193 | 194 | 195 | 196 | 197 | 198 | 199 | 200 | 201 | 205 | 206 | 207 | 208 | 209 | 210 | 211 | 212 | 213 | 214 | 215 | 216 | 217 | 218 | 219 | 220 | 221 | 222 | 223 | 224 | 225 | 226 | 227 | 228 | 229 | 230 | 231 | 232 | 233 | 234 | 235 | 236 | 237 | 238 | 239 | 240 | 241 | 242 | 243 | 244 | 245 | 246 | 247 | 248 | 249 | 250 | 251 | -------------------------------------------------------------------------------- /tests/objc/app/HSApp-xcode-prj/HSApp/main.m: -------------------------------------------------------------------------------- 1 | // 2 | // main.m 3 | // HSApp 4 | // 5 | // Created by Manuel M T Chakravarty on 13/04/13. 6 | // Copyright (c) 2013 Manuel M T Chakravarty. All rights reserved. 7 | // 8 | 9 | #import 10 | 11 | int main(int argc, char *argv[]) 12 | { 13 | return NSApplicationMain(argc, (const char **)argv); 14 | } 15 | -------------------------------------------------------------------------------- /tests/objc/app/HSApp.app/Contents/Info.plist: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | BuildMachineOSBuild 6 | 13B3116 7 | CFBundleDevelopmentRegion 8 | en 9 | CFBundleExecutable 10 | HSApp 11 | CFBundleIdentifier 12 | org.justtesting.HSApp 13 | CFBundleInfoDictionaryVersion 14 | 6.0 15 | CFBundleName 16 | HSApp 17 | CFBundlePackageType 18 | APPL 19 | CFBundleShortVersionString 20 | 1.0 21 | CFBundleSignature 22 | ???? 23 | CFBundleVersion 24 | 1 25 | DTCompiler 26 | com.apple.compilers.llvm.clang.1_0 27 | DTPlatformBuild 28 | 5A3005 29 | DTPlatformVersion 30 | GM 31 | DTSDKBuild 32 | 13A595 33 | DTSDKName 34 | macosx10.9 35 | DTXcode 36 | 0502 37 | DTXcodeBuild 38 | 5A3005 39 | LSApplicationCategoryType 40 | public.app-category.developer-tools 41 | LSMinimumSystemVersion 42 | 10.8 43 | NSHumanReadableCopyright 44 | Written by Manuel M T Chakravarty. 45 | NSMainNibFile 46 | MainMenu 47 | NSPrincipalClass 48 | NSApplication 49 | 50 | 51 | -------------------------------------------------------------------------------- /tests/objc/app/HSApp.app/Contents/MacOS/.gitkeep: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mchakravarty/language-c-inline/034128f80abc917040f42a10ce982775ae5e7387/tests/objc/app/HSApp.app/Contents/MacOS/.gitkeep -------------------------------------------------------------------------------- /tests/objc/app/HSApp.app/Contents/Resources/en.lproj/Credits.rtf: -------------------------------------------------------------------------------- 1 | {\rtf1\ansi\ansicpg1252\cocoartf1187\cocoasubrtf370 2 | \cocoascreenfonts1{\fonttbl\f0\fswiss\fcharset0 Helvetica;} 3 | {\colortbl;\red255\green255\blue255;} 4 | \paperw11900\paperh16840\vieww9600\viewh8400\viewkind0 5 | \pard\tx560\tx1120\tx1680\tx2240\tx2800\tx3360\tx3920\tx4480\tx5040\tx5600\tx6160\tx6720 6 | 7 | \f0\b\fs24 \cf0 Inline Objective-C in Haskell example app 8 | \b0 \ 9 | \ 10 | It demonstrates how to use in Objective-C\ 11 | in tandem with Haskell to write Cocoa apps.\ 12 | } -------------------------------------------------------------------------------- /tests/objc/app/HSApp.app/Contents/Resources/en.lproj/InfoPlist.strings: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mchakravarty/language-c-inline/034128f80abc917040f42a10ce982775ae5e7387/tests/objc/app/HSApp.app/Contents/Resources/en.lproj/InfoPlist.strings -------------------------------------------------------------------------------- /tests/objc/app/HSApp.app/Contents/Resources/en.lproj/MainMenu.nib: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mchakravarty/language-c-inline/034128f80abc917040f42a10ce982775ae5e7387/tests/objc/app/HSApp.app/Contents/Resources/en.lproj/MainMenu.nib -------------------------------------------------------------------------------- /tests/objc/app/Interpreter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE PackageImports #-} 3 | 4 | -- HSApp: a simple Cocoa app in Haskell 5 | -- 6 | -- Management of GHC interpreter sessions through the 'hint' package. 7 | -- 8 | -- Interpreter sessions run in their own thread. They receive interpreter commands as monadic 'Interpreter' computations 9 | -- via an inlet 'MVar'. These commands return the result of command execution via another 'MVar' specifically used only 10 | -- for this one command. 11 | -- 12 | 13 | module Interpreter ( 14 | Session, Result(..), 15 | start, stop, eval, typeOf, load 16 | ) where 17 | 18 | -- standard libraries 19 | import Prelude hiding (catch) 20 | import Control.Applicative 21 | import Control.Concurrent 22 | import Control.Exception (SomeException, evaluate) 23 | import Control.Monad 24 | import Control.Monad.Catch 25 | 26 | import System.IO 27 | 28 | -- hint 29 | import qualified Language.Haskell.Interpreter as Interp 30 | 31 | 32 | -- |Abstract handle of an interpreter session. 33 | -- 34 | newtype Session = Session (MVar (Maybe (Interp.Interpreter ()))) 35 | 36 | -- |Possible results of executing an interpreter action. 37 | -- 38 | data Result = Result String 39 | | Error String 40 | 41 | -- |Start a new interpreter session. 42 | -- 43 | start :: IO Session 44 | start 45 | = do 46 | { inlet <- newEmptyMVar 47 | ; forkIO $ void $ Interp.runInterpreter (startSession inlet) 48 | ; return $ Session inlet 49 | } 50 | where 51 | startSession inlet = Interp.setImports ["Prelude"] >> session inlet 52 | 53 | session inlet 54 | = do 55 | { maybeCommand <- Interp.lift $ takeMVar inlet 56 | ; case maybeCommand of 57 | Nothing -> return () 58 | Just command -> 59 | do 60 | { command 61 | ; session inlet 62 | } 63 | } 64 | 65 | -- Terminate an interpreter session. 66 | -- 67 | stop :: Session -> IO () 68 | stop (Session inlet) = putMVar inlet Nothing 69 | 70 | -- Evaluate a Haskell expression in the given interpreter session, 'show'ing its result. 71 | -- 72 | -- If GHC raises an error, we pretty print it. 73 | -- 74 | eval :: Session -> String -> IO Result 75 | eval (Session inlet) e 76 | = do 77 | { resultMV <- newEmptyMVar 78 | ; putMVar inlet $ Just $ -- the interpreter command we send over to the interpreter thread 79 | do 80 | { -- demand the result to force any contained exceptions 81 | ; result <- do { !result <- Interp.eval e 82 | ; return result } 83 | `catch` (return . pprError) 84 | `catch` (return . (show :: SomeException -> String)) 85 | ; Interp.lift $ putMVar resultMV (Result result) 86 | } 87 | ; takeMVar resultMV 88 | } 89 | 90 | -- Infer the type of a Haskell expression in the given interpreter session. 91 | -- 92 | -- If GHC raises an error, we pretty print it. 93 | -- 94 | typeOf :: Session -> String -> IO Result 95 | typeOf (Session inlet) e 96 | = do 97 | { resultMV <- newEmptyMVar 98 | ; putMVar inlet $ Just $ -- the interpreter command we send over to the interpreter thread 99 | do 100 | { -- demand the result to force any contained exceptions 101 | ; result <- do { !result <- Interp.typeOf e 102 | ; return result } 103 | `catch` (return . pprError) 104 | `catch` (return . (show :: SomeException -> String)) 105 | ; Interp.lift $ putMVar resultMV (Result result) 106 | } 107 | ; takeMVar resultMV 108 | } 109 | 110 | -- Load a module into in the given interpreter session. 111 | -- 112 | -- If GHC raises an error, we pretty print it. 113 | -- 114 | load :: Session -> String -> IO Result 115 | load (Session inlet) mname 116 | = do 117 | { resultMV <- newEmptyMVar 118 | ; putMVar inlet $ Just $ -- the interpreter command we send over to the interpreter thread 119 | do 120 | { -- demand the result to force any contained exceptions 121 | ; result <- do { Interp.loadModules [mname] 122 | ; mods <- Interp.getLoadedModules 123 | ; Interp.setTopLevelModules mods 124 | ; return ("Successfully loaded '" ++ mname ++ "'") } 125 | `catch` (return . pprError) 126 | `catch` (return . (show :: SomeException -> String)) 127 | ; Interp.lift $ putMVar resultMV (Result result) 128 | } 129 | ; takeMVar resultMV 130 | } 131 | 132 | pprError :: Interp.InterpreterError -> String 133 | pprError (Interp.UnknownError msg) = msg 134 | pprError (Interp.WontCompile errs) = "Compile time error: \n" ++ unlines (map Interp.errMsg errs) 135 | pprError (Interp.NotAllowed msg) = "Permission denied: " ++ msg 136 | pprError (Interp.GhcException msg) = "Internal error: " ++ msg 137 | -------------------------------------------------------------------------------- /tests/objc/app/Main.hs: -------------------------------------------------------------------------------- 1 | -- HSApp: a simple Cocoa app in Haskell 2 | -- 3 | -- Tying all components together 4 | 5 | import qualified App as App 6 | import qualified AppDelegate as Delegate 7 | 8 | main :: IO () 9 | main 10 | = do 11 | { App.objc_initialise 12 | ; Delegate.objc_initialise 13 | ; App.main 14 | } 15 | -------------------------------------------------------------------------------- /tests/objc/app/Makefile: -------------------------------------------------------------------------------- 1 | HC = ghc 2 | LIBDIR = $(shell $(HC) --print-libdir) 3 | CFLAGS = -fobjc-arc -I$(LIBDIR)/include -I$(LIBDIR)/../../includes 4 | HCFLAGS = 5 | LDFLAGS = -package template-haskell -package language-c-quote -package language-c-inline -package hint \ 6 | -framework Cocoa -optl-ObjC -threaded 7 | 8 | OBJS = Main.o App.o App_objc.o AppDelegate.o AppDelegate_objc.o Interpreter.o 9 | 10 | default: HSApp.app/Contents/MacOS/HSApp 11 | 12 | %.o: %.hs 13 | $(HC) -c $< $(HCFLAGS) 14 | 15 | Interpreter.o: 16 | AppDelegate.o: Interpreter.o 17 | App.o: 18 | Main.o: App.o AppDelegate.o 19 | 20 | App_objc.m: App.o 21 | AppDelegate_objc.m: AppDelegate.o 22 | 23 | HSApp: $(OBJS) 24 | $(HC) -o $@ $^ $(LDFLAGS) 25 | 26 | HSApp.app/Contents/MacOS/HSApp: HSApp 27 | cp $< $@ 28 | 29 | .PHONY: clean 30 | 31 | clean: 32 | rm -f *.o *.hi App_objc.[hm] AppDelegate_objc.[hm] *_stub.h HSApp HSApp.app/Contents/MacOS/HSApp 33 | -------------------------------------------------------------------------------- /tests/objc/app/Readme.md: -------------------------------------------------------------------------------- 1 | This example application implements a simple GUI around interactive GHC sessions. 2 | 3 | The GUI is done with Xcode (via a .xib). The corresponding Xcode project is in the subdirectory `HSApp-xcode-proj`. This, however, is not used to build the project. Instead, we have got a simple Makefile, that invokes GHC and clang to compile the various components, and finally, copies the binary into a pre-populated `.app` bundle. 4 | 5 | Currently, if you change the `.xib` in the Xcode project, you need to manually copy it into the appropriate location in the `.app` bundle. 6 | -------------------------------------------------------------------------------- /tests/objc/concept/MainInlineObjC.hs: -------------------------------------------------------------------------------- 1 | import TestInlineObjC 2 | 3 | main :: IO () 4 | main 5 | = do 6 | { objc_initialise 7 | ; dumpURL "https://raw.githubusercontent.com/mchakravarty/language-c-inline/master/tests/objc/concept/TestInlineObjC.hs" 8 | } 9 | -------------------------------------------------------------------------------- /tests/objc/concept/Makefile: -------------------------------------------------------------------------------- 1 | HC = ghc 2 | LIBDIR = $(shell $(HC) --print-libdir) 3 | CFLAGS = -fobjc-arc -I$(LIBDIR)/include -I$(LIBDIR)/../../includes 4 | HCFLAGS = 5 | LDFLAGS = -package template-haskell -package language-c-quote -package language-c-inline -framework Foundation 6 | 7 | OBJS = TestInlineObjC.o TestInlineObjC_objc.o MainInlineObjC.o 8 | 9 | default: InlineObjC 10 | 11 | %.o: %.hs 12 | $(HC) -c $< $(HCFLAGS) 13 | 14 | TestInlineObjC.o: 15 | MainInlineObjC.o: TestInlineObjC.o 16 | 17 | TestInlineObjC_objc.m: TestInlineObjC.o 18 | 19 | InlineObjC: $(OBJS) 20 | $(HC) -o $@ $^ $(LDFLAGS) 21 | 22 | .PHONY: clean 23 | 24 | clean: 25 | rm -f *.o *.hi TestInlineObjC_objc.[hm] InlineObjC -------------------------------------------------------------------------------- /tests/objc/concept/TestInlineObjC.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, QuasiQuotes #-} 2 | 3 | module TestInlineObjC (objc_initialise, dumpURL) where 4 | 5 | import Language.C.Quote.ObjC 6 | import Language.C.Inline.ObjC 7 | 8 | objc_import [""] 9 | 10 | 11 | dumpURL :: String -> IO () 12 | dumpURL urlString 13 | = do 14 | { urlData <- 15 | $(objc ['urlString :> ''String] $ ''String <: 16 | [cexp| 17 | [NSString stringWithContentsOfURL:[NSURL URLWithString:urlString] 18 | encoding:NSUTF8StringEncoding 19 | error:NULL] 20 | |]) 21 | ; putStr urlData 22 | } 23 | 24 | objc_emit 25 | -------------------------------------------------------------------------------- /tests/objc/marshal-array/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, QuasiQuotes, DeriveDataTypeable #-} 2 | 3 | import Control.Monad hiding (void) 4 | import Data.Typeable 5 | import Language.C.Quote.ObjC 6 | import Language.C.Inline.ObjC 7 | 8 | objc_import [""] 9 | 10 | 11 | newtype NSString = NSString (ForeignPtr NSString) 12 | deriving Typeable -- needed for now until migrating to new TH 13 | 14 | objc_typecheck -- make the above type declaration known to Template Haskell 15 | 16 | stringToNSString :: String -> IO NSString 17 | stringToNSString str 18 | = $(objc ['str :> ''String] $ Class ''NSString <: [cexp| str |]) 19 | 20 | newtype NSMutableArray e = NSMutableArray (ForeignPtr (NSMutableArray e)) 21 | deriving Typeable -- needed for now until migrating to new TH 22 | newtype NSArray e = NSArray (ForeignPtr (NSArray e)) 23 | deriving Typeable -- needed for now until migrating to new TH 24 | 25 | unsafeFreezeNSMutableArray :: NSMutableArray e -> NSArray e 26 | unsafeFreezeNSMutableArray (NSMutableArray fptr) = NSArray $ castForeignPtr fptr 27 | 28 | objc_typecheck 29 | 30 | listOfStringToNSArray :: [String] -> IO (NSArray NSString) 31 | listOfStringToNSArray strs 32 | = do 33 | { marr <- $(objc [] $ Class [t|NSMutableArray NSString|] <: [cexp| [NSMutableArray arrayWithCapacity:10] |]) 34 | ; mapM_ (addElement marr) strs 35 | ; return $ unsafeFreezeNSMutableArray marr 36 | } 37 | where 38 | addElement marr str 39 | = $(objc ['marr :> Class [t|NSMutableArray NSString|], 'str :> ''String] $ void [cexp| [marr addObject:str] |]) 40 | 41 | nsArrayToListOfString :: NSArray NSString -> IO [String] 42 | nsArrayToListOfString = error "not needed here" 43 | 44 | objc_marshaller 'listOfStringToNSArray 'nsArrayToListOfString 45 | 46 | go :: IO () 47 | go = $(objc ['msgs :> [t| [String] |]] $ void [cexp| NSLog(@"%@", msgs.description) |]) 48 | where 49 | msgs = ["Hello", "World!", "This is a bunch of 'String's!"] 50 | 51 | objc_emit 52 | 53 | 54 | main = objc_initialise >> go 55 | -------------------------------------------------------------------------------- /tests/objc/marshal-array/Makefile: -------------------------------------------------------------------------------- 1 | HC = ghc 2 | LIBDIR = $(shell $(HC) --print-libdir) 3 | CFLAGS = -fobjc-arc -I$(LIBDIR)/include -I$(LIBDIR)/../../includes 4 | HCFLAGS = 5 | LDFLAGS = -package template-haskell -package language-c-quote -package language-c-inline -framework Foundation 6 | 7 | OBJS = Main.o Main_objc.o 8 | 9 | default: MarshalArray 10 | 11 | %.o: %.hs 12 | $(HC) -c $< $(HCFLAGS) 13 | 14 | Main.o: 15 | 16 | Main_objc.m: Main.o 17 | 18 | MarshalArray: $(OBJS) 19 | $(HC) -o $@ $^ $(LDFLAGS) 20 | 21 | .PHONY: clean 22 | 23 | clean: 24 | rm -f *.o *.hi Main_objc.[hm] MarshalArray -------------------------------------------------------------------------------- /tests/objc/minimal/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, QuasiQuotes #-} 2 | 3 | import Language.C.Quote.ObjC 4 | import Language.C.Inline.ObjC 5 | 6 | import Language.Haskell.TH 7 | 8 | objc_import [""] 9 | 10 | nslog :: String -> IO () 11 | 12 | nslog msg = $(objc ['msg :> ''String] (void [cexp| NSLog(@"Here is a message from Haskell: %@", msg) |])) 13 | 14 | objc_emit 15 | 16 | 17 | main = objc_initialise >> nslog "I like Objective-C!" 18 | -------------------------------------------------------------------------------- /tests/objc/minimal/Makefile: -------------------------------------------------------------------------------- 1 | HC = ghc 2 | LIBDIR = $(shell $(HC) --print-libdir) 3 | CFLAGS = -fobjc-arc -I$(LIBDIR)/include -I$(LIBDIR)/../../includes 4 | HCFLAGS = 5 | LDFLAGS = -package template-haskell -package language-c-quote -package language-c-inline -framework Foundation 6 | 7 | OBJS = Main.o Main_objc.o 8 | 9 | default: Minimal 10 | 11 | %.o: %.hs 12 | $(HC) -c $< $(HCFLAGS) 13 | 14 | Main.o: 15 | 16 | Main_objc.m: Main.o 17 | 18 | Minimal: $(OBJS) 19 | $(HC) -o $@ $^ $(LDFLAGS) 20 | 21 | .PHONY: clean 22 | 23 | clean: 24 | rm -f *.o *.hi Main_objc.[hm] Minimal -------------------------------------------------------------------------------- /tests/objc/record/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, QuasiQuotes #-} 2 | 3 | import Language.C.Quote.ObjC 4 | import Language.C.Inline.ObjC 5 | 6 | objc_import ["", "Particle_objc.h"] 7 | 8 | go :: IO () 9 | go = $(objc [] $ void [cexp| ({ 10 | typename Particle *particle = [Particle particleWithMass:1.0]; 11 | NSLog(@"The mass is %f", particle.mass); 12 | }) |]) 13 | 14 | objc_emit 15 | 16 | 17 | main = objc_initialise >> go 18 | -------------------------------------------------------------------------------- /tests/objc/record/Makefile: -------------------------------------------------------------------------------- 1 | HC = ghc 2 | LIBDIR = $(shell $(HC) --print-libdir) 3 | CFLAGS = -fobjc-arc -I$(LIBDIR)/include -I$(LIBDIR)/../../includes 4 | HCFLAGS = 5 | LDFLAGS = -package template-haskell -package language-c-quote -package language-c-inline -framework Foundation 6 | 7 | OBJS = Main.o Main_objc.o Particle.o Particle_objc.o 8 | 9 | default: Particle 10 | 11 | %.o: %.hs 12 | $(HC) -c $< $(HCFLAGS) 13 | 14 | Particle.o: 15 | Main.o: Particle.o 16 | 17 | Main_objc.m: Main.o 18 | Particle_objc.m: Particle.o 19 | 20 | Particle: $(OBJS) 21 | $(HC) -o $@ $^ $(LDFLAGS) 22 | 23 | .PHONY: clean 24 | 25 | clean: 26 | rm -f *.o *.hi Main_objc.[hm] Particle_objc.[hm] *_stub.h Particle 27 | -------------------------------------------------------------------------------- /tests/objc/record/Particle.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, QuasiQuotes #-} 2 | 3 | -- Marshalling a record structure 4 | 5 | module Particle (objc_initialise) where 6 | 7 | -- language-c-inline 8 | import Language.C.Quote.ObjC 9 | import Language.C.Inline.ObjC 10 | 11 | objc_import [""] 12 | 13 | 14 | -- Haskell code used from Objective-C. 15 | 16 | type Point = (Float, Float) 17 | 18 | origin = (0, 0) 19 | 20 | newtype Vector = Vector (Float, Float) 21 | 22 | zero = Vector (0, 0) 23 | 24 | data Particle = Particle 25 | { mass :: Float 26 | , loc :: Point 27 | , vel :: Vector 28 | , acc :: Vector 29 | } 30 | 31 | newParticle :: Float -> Particle 32 | newParticle mass = Particle mass origin zero zero 33 | 34 | objc_record "" "Particle" ''Particle [Typed 'newParticle] 35 | [ [objcprop| @property (readonly) float mass; |] --> 'mass 36 | , [objcprop| @property (readonly) float locX; |] ==> ([t| Float |], 37 | [| fst . loc |], 38 | [| \p locX -> p { loc = (locX, snd . loc $ p) } |]) 39 | , [objcprop| @property (readonly) float locY; |] ==> ([t| Float |], 40 | [| snd . loc |], 41 | [| \p locY -> p { loc = (fst . loc $ p, locY) } |]) 42 | ] 43 | [objcifdecls| 44 | + (instancetype)particleWithMass:(float)mass; 45 | |] 46 | [objcimdecls| 47 | + (instancetype)particleWithMass:(float)mass 48 | { 49 | return [[Particle alloc] initWithParticleHsPtr:newParticle(mass)]; 50 | } 51 | |] 52 | 53 | objc_emit 54 | -------------------------------------------------------------------------------- /tests/testsuite.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | import Language.C.Quote.C 4 | import Language.C.Inline.C 5 | import Language.Haskell.TH 6 | import Test.Hspec 7 | import Test.HUnit (assertBool) 8 | 9 | import Test.PosixC 10 | 11 | 12 | main :: IO () 13 | main = do 14 | posixCInit 15 | #if (__APPLE__ && __MACH__) 16 | hspec $ do 17 | -- The PosixC test suite should also run on Mac, but the ObjC one 18 | -- needs Apple's ObjC. 19 | testPosixC 20 | testObjC 21 | #else 22 | hspec 23 | testPosixC 24 | #endif 25 | 26 | #if (__APPLE__ && __MACH__) 27 | testObjC :: Spec 28 | testObjC = 29 | describe "ObjC:" $ 30 | error "Not ObjC test suite defined yet." 31 | #endif 32 | 33 | -- Hack together a simple type class to represent 34 | -- approximate equality for floating-point types. 35 | -- It is only intended for the simple cases used here; 36 | -- I assume there's something out there on Hackage 37 | -- which has a more-principled approach. 38 | -- 39 | class EqualIsh a where 40 | -- | Returns `True` if the two values are close 41 | -- enough to be considered equal. 42 | (=~) :: a -> a -> Bool 43 | (=~) a b = not $ a /=~ b 44 | 45 | -- | Returns `True` if the two values are not close 46 | -- enough to be considered equal. 47 | (/=~) :: a -> a -> Bool 48 | (/=~) a b = not $ a =~ b 49 | 50 | instance EqualIsh a => EqualIsh [a] where 51 | (=~) = go 52 | where 53 | go [] [] = True 54 | go (a:as) (b:bs) | a =~ b = go as bs 55 | | otherwise = False 56 | go _ _ = False 57 | 58 | -- | This is a very naive definition of approximate 59 | -- eqaulity (absolute difference within 1e-15; 60 | -- this value is just picked at random rather than 61 | -- based on anything sensible like the ulp or a 62 | -- fractional difference). 63 | instance EqualIsh Double where 64 | a =~ b = let d = abs $ a - b 65 | in d < 1e-15 66 | 67 | -- | This is a very naive definition of approximate 68 | -- eqaulity (absolute difference within 5e-7; 69 | -- this value is just picked at random rather than 70 | -- based on anything sensible like the ulp or a 71 | -- fractional difference). 72 | instance EqualIsh Float where 73 | a =~ b = let d = abs $ a - b 74 | in d < 5e-7 75 | 76 | -- | 77 | -- @actual \`shouldBeIsh\` expected@ sets the expectation that @actual@ is equal 78 | -- to @expected@ (as defined by the `EqualIsh` instance). 79 | shouldBeIsh :: (Show a, EqualIsh a) => a -> a -> Expectation 80 | actual `shouldBeIsh` expected = 81 | assertBool 82 | ("Value " ++ show actual ++ " not equalIsh to " ++ show expected) 83 | (actual =~ expected) 84 | 85 | -- | 86 | -- @action \`shouldReturnIsh\` expected@ sets the expectation that @action@ 87 | -- returns @expected@ (as defined by the `EqualIsh` instance). 88 | shouldReturnIsh :: (Show a, EqualIsh a) => IO a -> a -> Expectation 89 | action `shouldReturnIsh` expected = action >>= (`shouldBeIsh` expected) 90 | 91 | testPosixC :: Spec 92 | testPosixC = 93 | describe "PosixC:" $ do 94 | it "Can pass an Int through a C function." $ 95 | mapM cPlusOne [0, 1, 2] `shouldReturn` [ 1, 2, 3 ] 96 | it "Can compare two strings using C strcmp." $ do 97 | cStringCompare "abc" "bbc" `shouldReturn` LT 98 | cStringCompare "bbc" "abc" `shouldReturn` GT 99 | cStringCompare "abc" "abc" `shouldReturn` EQ 100 | cStringCompare "" "" `shouldReturn` EQ 101 | it "Can retreve Strings from C code." $ 102 | cGetString `shouldReturn` "Hello Haskell" 103 | it "Can pass Strings through C code.." $ do 104 | cPassString "abc" `shouldReturn` "abc" 105 | cPassString "abcde" `shouldReturn` "abcde" 106 | cPassString "" `shouldReturn` "" 107 | 108 | -- type specifiers are not required; added for 109 | -- documentation 110 | it "Can pass a Double through a C function.." $ 111 | mapM cSin [0, pi/2.0, pi] `shouldReturnIsh` [ 0.0, 1.0, 0.0 :: Double ] 112 | it "Can pass a Float through a C function.." $ 113 | mapM cSinF [0, pi/2.0, pi] `shouldReturnIsh` [ 0.0, 1.0, 0.0 :: Float ] 114 | it "Can pass a Double through a slightly-complicated C function.." $ 115 | mapM cInvertSin [0.0, 1.0] `shouldReturnIsh` [0.0, 1.0 :: Double ] 116 | it "Can pass a Float through a slightly-complicated C function.." $ 117 | mapM cInvertSinF [0.0, 1.0] `shouldReturnIsh` [0.0, 1.0 :: Float ] 118 | --------------------------------------------------------------------------------