diff --git a/Language/C/Inline/Hint.hs b/Language/C/Inline/Hint.hs --- a/Language/C/Inline/Hint.hs +++ b/Language/C/Inline/Hint.hs @@ -2,7 +2,7 @@ -- | -- Module : Language.C.Inline.Hint --- Copyright : [2013..2014] Manuel M T Chakravarty +-- Copyright : [2013..2016] Manuel M T Chakravarty -- License : BSD3 -- -- Maintainer : Manuel M T Chakravarty @@ -19,7 +19,7 @@ Hint(..), -- * Querying of annotated entities - haskellTypeOf, foreignTypeOf, stripAnnotation + haskellTypeOf, foreignTypeOf, newForeignPtrOf, stripAnnotation ) where -- common libraries @@ -62,19 +62,22 @@ -- |Hints imply marshalling strategies, which include source and destination types for marshalling. -- class Hint hint where - haskellType :: hint -> Q TH.Type - foreignType :: hint -> Q (Maybe QC.Type) -- ^In case of 'Nothing', the foreign type is determined by the Haskell type. - showQ :: hint -> Q String + haskellType :: hint -> Q TH.Type + foreignType :: hint -> Q (Maybe QC.Type) -- ^In case of 'Nothing', the foreign type is determined by the Haskell type. + showQ :: hint -> Q String + newForeignPtrName :: hint -> Q (Maybe TH.Name) instance Hint Name where -- must be a type name - haskellType = conT - foreignType = const (return Nothing) - showQ = return . show + haskellType = conT + foreignType = const (return Nothing) + showQ = return . show + newForeignPtrName = const (return Nothing) instance Hint (Q TH.Type) where - haskellType = id - foreignType = const (return Nothing) - showQ = (show <$>) + haskellType = id + foreignType = const (return Nothing) + showQ = (show <$>) + newForeignPtrName = const (return Nothing) -- |Determine the Haskell type implied for the given annotated entity. -- @@ -99,6 +102,12 @@ foreignTypeOf :: Annotated e -> Q (Maybe QC.Type) foreignTypeOf (_ :> hint) = foreignType hint foreignTypeOf (Typed name) = return Nothing + +-- |Determine the name of the function to create a new foreign pointer for this type if any. +-- +newForeignPtrOf :: Annotated e -> Q (Maybe TH.Name) +newForeignPtrOf (_ :> hint) = newForeignPtrName hint +newForeignPtrOf (Typed name) = return Nothing -- |Remove the annotation. -- diff --git a/Language/C/Inline/ObjC.hs b/Language/C/Inline/ObjC.hs --- a/Language/C/Inline/ObjC.hs +++ b/Language/C/Inline/ObjC.hs @@ -2,7 +2,7 @@ -- | -- Module : Language.C.Inline.ObjC --- Copyright : [2013] Manuel M T Chakravarty +-- Copyright : [2013..2016] Manuel M T Chakravarty -- License : BSD3 -- -- Maintainer : Manuel M T Chakravarty @@ -15,15 +15,19 @@ -- * Re-export types from 'Foreign.C' module Foreign.C.Types, CString, CStringLen, CWString, CWStringLen, Errno, ForeignPtr, castForeignPtr, - + -- * Re-export types from Template Haskell Name, + -- * Objective-C memory management support + objc_retain, objc_release, objc_release_ptr, newForeignClassPtr, newForeignStructPtr, + -- * Combinators for inline Objective-C - objc_import, objc_interface, objc_implementation, objc_record, objc_marshaller, objc_typecheck, objc, objc_emit, + objc_import, objc_interface, objc_implementation, objc_record, objc_marshaller, objc_class_marshaller, + objc_struct_marshaller, objc_typecheck, objc, objc_emit, -- * Marshalling annotations - Annotated(..), (<:), void, Class(..), IsType, + Annotated(..), (<:), void, Class(..), Struct(..), IsType, -- * Property maps PropertyAccess, (==>), (-->) @@ -62,6 +66,9 @@ import Language.C.Inline.ObjC.Marshal +-- Combinators for inline Objective-C +-- ---------------------------------- + -- |Specify imported Objective-C files. Needs to be spliced where an import declaration can appear. (Just put it -- straight after all the import statements in the module.) -- @@ -133,7 +140,7 @@ { -- Determine the bridging type and the marshalling code ; (bridgeArgTys, cBridgeArgTys, hsArgMarshallers, cArgMarshallers) <- - unzip4 <$> zipWithM generateCToHaskellMarshaller argTys cArgTys + unzip4 <$> zipWithM (generateCToHaskellMarshaller Nothing) argTys cArgTys ; (bridgeResTy, cBridgeResTy, hsResMarshaller, cResMarshaller) <- generateHaskellToCMarshaller resTy cResTy -- Haskell type of the foreign wrapper function @@ -378,13 +385,30 @@ where propTy = QC.Type spec decl loc +-- |Deprecated: use 'objc_class_marshaller' or 'objc_struct_marshaller' instead +-- +objc_marshaller :: TH.Name -> TH.Name -> Q [TH.Dec] +{-# DEPRECATED objc_marshaller "use 'objc_class_marshaller' or 'objc_struct_marshaller' instead" #-} +objc_marshaller = objc_class_marshaller + -- |Declare a Haskell<->Objective-C marshaller pair to be used in all subsequent marshalling code generation. -- -- On the Objective-C side, the marshallers must use a wrapped foreign pointer to an Objective-C class (just as those -- of 'Class' hints). The domain and codomain of the two marshallers must be the opposite and both are executing in 'IO'. -- -objc_marshaller :: TH.Name -> TH.Name -> Q [TH.Dec] -objc_marshaller haskellToObjCName objcToHaskellName +objc_class_marshaller :: TH.Name -> TH.Name -> Q [TH.Dec] +objc_class_marshaller = objc_marshaller' 'newForeignClassPtr + +-- |Declare a Haskell<->Objective-C marshaller pair to be used in all subsequent marshalling code generation. +-- +-- On the Objective-C side, the marshallers must use a wrapped foreign pointer to an C struct (just as those +-- of 'Struct' hints). The domain and codomain of the two marshallers must be the opposite and both are executing in 'IO'. +-- +objc_struct_marshaller :: TH.Name -> TH.Name -> Q [TH.Dec] +objc_struct_marshaller = objc_marshaller' 'newForeignStructPtr + +objc_marshaller' :: TH.Name -> TH.Name -> TH.Name -> Q [TH.Dec] +objc_marshaller' newForeignPtrFun haskellToObjCName objcToHaskellName = do { -- check that the marshallers have compatible types ; (hsTy1, classTy1) <- argAndResultTy haskellToObjCName @@ -395,7 +419,7 @@ ; tyconName <- headTyConNameOrError QC.ObjC classTy1 ; let cTy = [cty| typename $id:(nameBase tyconName) * |] - ; stashMarshaller (hsTy1, classTy1, cTy, haskellToObjCName, objcToHaskellName) + ; stashMarshaller (hsTy1, classTy1, cTy, haskellToObjCName, objcToHaskellName, newForeignPtrFun) ; return [] } where @@ -425,6 +449,7 @@ ; let vars = map stripAnnotation ann_vars ; varTys <- mapM haskellTypeOf ann_vars ; resTy <- haskellTypeOf ann_e + ; newFP <- newForeignPtrOf ann_e -- Determine C types ; maybe_cArgTys <- mapM annotatedHaskellTypeToCType ann_vars @@ -441,7 +466,7 @@ ; (bridgeArgTys, cBridgeArgTys, hsArgMarshallers, cArgMarshallers) <- unzip4 <$> zipWithM generateHaskellToCMarshaller varTys cArgTys ; (bridgeResTy, cBridgeResTy, hsResMarshaller, cResMarshaller) <- - generateCToHaskellMarshaller resTy cResTy + generateCToHaskellMarshaller newFP resTy cResTy -- Haskell type of the foreign wrapper function ; let hsWrapperTy = haskellWrapperType [] bridgeArgTys bridgeResTy diff --git a/Language/C/Inline/ObjC/Hint.hs b/Language/C/Inline/ObjC/Hint.hs --- a/Language/C/Inline/ObjC/Hint.hs +++ b/Language/C/Inline/ObjC/Hint.hs @@ -2,7 +2,7 @@ -- | -- Module : Language.C.Inline.ObjC.Hint --- Copyright : 2014 Manuel M T Chakravarty +-- Copyright : [2014..2016] Manuel M T Chakravarty -- License : BSD3 -- -- Maintainer : Manuel M T Chakravarty @@ -12,8 +12,8 @@ -- This module provides Objective-C specific hints. module Language.C.Inline.ObjC.Hint ( - -- * Class hints - Class(..), IsType + -- * Class and Struct hints + Class(..), Struct(..), IsType ) where -- standard libraries @@ -28,6 +28,7 @@ import Language.C.Inline.Error import Language.C.Inline.Hint import Language.C.Inline.TH +import Language.C.Inline.ObjC.Marshal -- |Class of entities that can be used as TH types. @@ -80,3 +81,34 @@ { ty <- theType tyish ; return $ "Class " ++ show ty } + newForeignPtrName (Class _) + = return $ Just 'newForeignClassPtr + +-- |Hint indicating to marshal a pointer to a C struct as a foreign pointer, where the argument is the Haskell type +-- representing the C type name. The Haskell type name must coincide with the C type name. +-- +-- NB: This is like `Class` with the difference that finalisers on foreign pointers created during marshalling use +-- 'free' rather than 'release'. +-- +data Struct where + Struct :: IsType t => t -> Struct + +instance Hint Struct where + haskellType (Struct tyish) + = do + { ty <- theType tyish + ; foreignWrapperDatacon ty -- FAILS if the declaration is not a 'ForeignPtr' wrapper + ; return ty + } + foreignType (Struct tyish) + = do + { name <- theType tyish >>= headTyConNameOrError QC.ObjC + ; return $ Just [cty| typename $id:(nameBase name) * |] + } + showQ (Struct tyish) + = do + { ty <- theType tyish + ; return $ "Struct " ++ show ty + } + newForeignPtrName (Struct _) + = return $ Just 'newForeignStructPtr diff --git a/Language/C/Inline/ObjC/Marshal.hs b/Language/C/Inline/ObjC/Marshal.hs --- a/Language/C/Inline/ObjC/Marshal.hs +++ b/Language/C/Inline/ObjC/Marshal.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE PatternGuards, TemplateHaskell, QuasiQuotes #-} +{-# LANGUAGE PatternGuards, TemplateHaskell, QuasiQuotes, ForeignFunctionInterface #-} -- | -- Module : Language.C.Inline.ObjC.Marshal --- Copyright : [2013] Manuel M T Chakravarty +-- Copyright : [2013..2016] Manuel M T Chakravarty -- License : BSD3 -- -- Maintainer : Manuel M T Chakravarty @@ -14,6 +14,10 @@ -- FIXME: Some of the code can go into a module for general marshalling, as only some of it is ObjC-specific. module Language.C.Inline.ObjC.Marshal ( + + -- * Objective-C memory management support + objc_retain, objc_release, objc_release_ptr, newForeignClassPtr, newForeignStructPtr, + -- * Determine corresponding foreign types of Haskell types haskellTypeToCType, @@ -48,6 +52,27 @@ import Language.C.Inline.TH +-- Objective-C memory management support from the Objective-C runtime +-- ------------------------------------------------------------------ + +foreign import ccall "objc_retain" objc_retain :: C.Ptr a -> IO (C.Ptr a) +foreign import ccall "objc_release" objc_release :: C.Ptr a -> IO () +foreign import ccall "&objc_release" objc_release_ptr :: C.FunPtr (C.Ptr a -> IO ()) + +-- |Turn a retainable Objective-C pointer into a foreign pointer that is released when finalised. +-- +-- NB: We need to retain the pointer first as it won't come with a +1 retain count for Haskell land to consume +-- (at best, it will have an autoreleased +1 if it is a function return result). +-- +newForeignClassPtr :: C.Ptr a -> IO (C.ForeignPtr a) +newForeignClassPtr ptr = objc_retain ptr >>= newForeignPtr objc_release_ptr + +-- |Turn a non-retainable C pointer into a foreign pointer that is freed when finalised. +-- +newForeignStructPtr :: C.Ptr a -> IO (C.ForeignPtr a) +newForeignStructPtr ptr = newForeignPtr finalizerFree ptr + + -- Determine foreign types -- ----------------------- @@ -60,8 +85,8 @@ = do { maybe_marshaller <- lookupMarshaller ty ; case maybe_marshaller of - Just (_, _, cTy, _, _) -> return $ Just cTy -- use a custom marshaller if one is available for this type - Nothing -> haskellTypeToCType' lang ty -- otherwise, continue below... + Just (_, _, cTy, _, _, _) -> return $ Just cTy -- use a custom marshaller if one is available for this type + Nothing -> haskellTypeToCType' lang ty -- otherwise, continue below... } where haskellTypeToCType' lang (ListT `AppT` (ConT char)) -- marshal '[Char]' as 'String' @@ -200,8 +225,8 @@ = do { maybe_marshaller <- lookupMarshaller hsTy ; case maybe_marshaller of - Just (_, classTy, cTy', haskellToC, _cToHaskell) - | cTy' == cTy -- custom marshaller mapping to an Objective-C class + Just (_, classTy, cTy', haskellToC, _cToHaskell, _newForeignPtr) + | cTy' == cTy -- custom marshaller mapping to an Objective-C class or struct -> return ( ptrOfForeignPtrWrapper classTy , cTy , \val cont -> [| do @@ -299,6 +324,9 @@ -- |Generate the type-specific marshalling code for Haskell to C land marshalling for a C-Haskell type pair. -- +-- The first argument is a function to turn a pointer into a foreign pointer in the case where an explicit 'Class' or +-- 'Struct' hint was provided. +-- -- The result has the following components: -- -- * Haskell type after Haskell-side marshalling. @@ -306,27 +334,33 @@ -- * Generator for the Haskell-side marshalling code. -- * Generator for the C-side marshalling code. -- -generateCToHaskellMarshaller :: TH.Type -> QC.Type -> Q (TH.TypeQ, QC.Type, HaskellMarshaller, CMarshaller) -generateCToHaskellMarshaller hsTy cTy@(Type (DeclSpec _ _ (Tnamed (Id name _) _ _) _) (Ptr _ (DeclRoot _) _) _) +generateCToHaskellMarshaller :: Maybe TH.Name -> TH.Type -> QC.Type -> Q (TH.TypeQ, QC.Type, HaskellMarshaller, CMarshaller) +generateCToHaskellMarshaller (Just newForeignPtr) + hsTy + cTy@(Type (DeclSpec _ _ (Tnamed (Id name _) _ _) _) (Ptr _ (DeclRoot _) _) _) | Just name == maybeHeadName -- ForeignPtr mapped to an Objective-C class = return ( ptrOfForeignPtrWrapper hsTy , cTy , \val cont -> do { let datacon = foreignWrapperDatacon hsTy - ; [| do { fptr <- newForeignPtr_ $val; $cont ($datacon fptr) } |] + ; [| do { fptr <- $(varE newForeignPtr) $val; $cont ($datacon fptr) } |] } , \argName -> [cexp| $id:(show argName) |] ) - | otherwise + where + maybeHeadName = fmap nameBase $ headTyConName hsTy +generateCToHaskellMarshaller Nothing + hsTy + cTy = do { maybe_marshaller <- lookupMarshaller hsTy ; case maybe_marshaller of - Just (_, classTy, cTy', _haskellToC, cToHaskell) - | cTy' == cTy -- custom marshaller mapping to an Objective-C class + Just (_, classTy, cTy', _haskellToC, cToHaskell, newForeignPtr) + | cTy' == cTy -- custom marshaller mapping to an Objective-C class or struct -> return ( ptrOfForeignPtrWrapper classTy , cTy , \val cont -> do { let datacon = foreignWrapperDatacon classTy ; [| do - { fptr <- newForeignPtr_ $val + { fptr <- $(varE newForeignPtr) $val ; hsVal <- $(varE cToHaskell) ($datacon fptr) ; $cont hsVal } |] @@ -336,15 +370,13 @@ Nothing -- other => continue below -> generateCToHaskellMarshaller' hsTy cTy } - where - maybeHeadName = fmap nameBase $ headTyConName hsTy -generateCToHaskellMarshaller hsTy cTy = generateCToHaskellMarshaller' hsTy cTy +generateCToHaskellMarshaller _ hsTy cTy = generateCToHaskellMarshaller' hsTy cTy generateCToHaskellMarshaller' :: TH.Type -> QC.Type -> Q (TH.TypeQ, QC.Type, HaskellMarshaller, CMarshaller) generateCToHaskellMarshaller' hsTy@(ConT maybe `AppT` argTy) cTy | maybe == ''Maybe && isCPtrType cTy = do - { (argTy', cTy', hsMarsh, cMarsh) <- generateCToHaskellMarshaller argTy cTy + { (argTy', cTy', hsMarsh, cMarsh) <- generateCToHaskellMarshaller Nothing argTy cTy ; ty <- argTy' ; resolve ty argTy' cTy' hsMarsh cMarsh } diff --git a/Language/C/Inline/State.hs b/Language/C/Inline/State.hs --- a/Language/C/Inline/State.hs +++ b/Language/C/Inline/State.hs @@ -2,7 +2,7 @@ -- | -- Module : Language.C.Inline.State --- Copyright : [2013] Manuel M T Chakravarty +-- Copyright : [2013..2016] Manuel M T Chakravarty -- License : BSD3 -- -- Maintainer : Manuel M T Chakravarty @@ -34,11 +34,12 @@ import Language.C.Quote as QC -type CustomMarshaller = ( TH.Type -- Haskell type - , TH.Type -- Haskell-side class type - , QC.Type -- C type - , TH.Name -- Haskell->C marshaller function - , TH.Name) -- C->Haskell marshaller function +type CustomMarshaller = ( TH.Type -- Haskell type + , TH.Type -- Haskell-side class type + , QC.Type -- C type + , TH.Name -- Haskell->C marshaller function + , TH.Name -- C->Haskell marshaller function + , TH.Name) -- C->Haskell pointer marshalling data State = State @@ -123,7 +124,7 @@ lookupMarshaller ty = do { marshallers <- getMarshallers - ; case filter (\(hsTy, _, _, _, _) -> hsTy == ty) marshallers of + ; case filter (\(hsTy, _, _, _, _, _) -> hsTy == ty) marshallers of [] -> return Nothing marshaller:_ -> return $ Just marshaller } diff --git a/Language/C/Inline/TH.hs b/Language/C/Inline/TH.hs --- a/Language/C/Inline/TH.hs +++ b/Language/C/Inline/TH.hs @@ -2,7 +2,7 @@ -- | -- Module : Language.C.Inline.TH --- Copyright : 2014 Manuel M T Chakravarty +-- Copyright : [2014..2016] Manuel M T Chakravarty -- License : BSD3 -- -- Maintainer : Manuel M T Chakravarty @@ -17,6 +17,7 @@ -- * Decompose idiomatic declarations foreignWrapperDatacon, ptrOfForeignPtrWrapper, unwrapForeignPtrWrapper + ) where -- standard libraries @@ -24,9 +25,11 @@ import Foreign.Ptr import Foreign.ForeignPtr import Language.Haskell.TH as TH +import Language.Haskell.TH.Quote as TH import Language.Haskell.TH.Syntax as TH -- quasi-quotation libraries +import Language.C.Parser as QC import Language.C.Quote as QC -- friends diff --git a/language-c-inline.cabal b/language-c-inline.cabal --- a/language-c-inline.cabal +++ b/language-c-inline.cabal @@ -1,7 +1,7 @@ Name: language-c-inline -Version: 0.7.9.2 +Version: 0.7.10.0 Cabal-version: >= 1.9.2 -Tested-with: GHC == 7.10.2 +Tested-with: GHC == 7.10.3 Build-type: Simple Synopsis: Inline C & Objective-C code in Haskell for language interoperability @@ -15,6 +15,8 @@ For more information, see . . Known bugs: + . + * New in 0.7.10: Distinction between 'Class' (NSObject pointers) and 'Struct' (C pointers) in both hints and marhsallers. . * New in 0.7.9: C wrapper names include the filename to disambiguate linker symbols. .