language-c-inline 0.6.0.0 → 0.7.6.0
raw patch · 13 files changed
+856/−184 lines, 13 filesdep ~language-c-quote
Dependency ranges changed: language-c-quote
Files
- Language/C/Inline/Error.hs +21/−16
- Language/C/Inline/Hint.hs +22/−3
- Language/C/Inline/ObjC.hs +295/−20
- Language/C/Inline/ObjC/Hint.hs +82/−0
- Language/C/Inline/ObjC/Marshal.hs +220/−70
- Language/C/Inline/State.hs +27/−3
- Language/C/Inline/TH.hs +149/−0
- README.md +1/−1
- language-c-inline.cabal +15/−8
- tests/objc/app/AppDelegate.hs +1/−1
- tests/objc/concept/Makefile +2/−0
- tests/objc/minimal/Makefile +2/−0
- tests/objc/record/Particle.hs +19/−62
Language/C/Inline/Error.hs view
@@ -13,7 +13,7 @@ module Language.C.Inline.Error ( -- * Error reporting- reportErrorAndFail,+ reportErrorWithLang, reportErrorAndFail, -- * Exception handling tryWithPlaceholder,@@ -31,11 +31,23 @@ import Text.PrettyPrint.Mainland as QC +reportErrorWithLang :: QC.Extensions -> String -> Q ()+reportErrorWithLang lang msg+ = do+ { loc <- location+ -- FIXME: define a Show instance for 'Loc' and use it to prefix position to error+ ; TH.reportError $ "Inline " ++ showLang lang ++ ": " ++ msg+ }+ reportErrorAndFail :: QC.Extensions -> String -> Q a reportErrorAndFail lang msg+ = reportErrorAndFail' $ "Inline " ++ showLang lang ++ ": " ++ msg++reportErrorAndFail' :: String -> Q a+reportErrorAndFail' msg = do- { reportError' lang msg- ; fail "Failure"+ { TH.reportError msg+ ; fail "Fatal error due to inline code" } -- reportErrorAndBail :: String -> Q TH.Exp@@ -46,19 +58,12 @@ -- ; return $ VarE undefinedName -- } -reportError' :: QC.Extensions -> String -> Q ()-reportError' lang msg- = do- { loc <- location- -- FIXME: define a Show instance for 'Loc' and use it to prefix position to error- ; TH.reportError $ "Inline " ++ showLang lang ++ ": " ++ msg- }- where- showLang QC.Antiquotation = "C"- showLang QC.Gcc = "GCC C"- showLang QC.CUDA = "CUDA C"- showLang QC.OpenCL = "OpenCL"- showLang QC.ObjC = "Objective-C"+showLang :: QC.Extensions -> String+showLang QC.Antiquotation = "C"+showLang QC.Gcc = "GCC C"+showLang QC.CUDA = "CUDA C"+showLang QC.OpenCL = "OpenCL"+showLang QC.ObjC = "Objective-C" -- If the tried computation fails, insert a placeholder expression. --
Language/C/Inline/Hint.hs view
@@ -13,16 +13,17 @@ module Language.C.Inline.Hint ( -- * Annotations- Annotated(..), (<:), void,+ Annotated(..), (<:), void, annotatedShowQ, -- * Hints Hint(..), -- * Querying of annotated entities- haskellTypeOf, stripAnnotation+ haskellTypeOf, foreignTypeOf, stripAnnotation ) where -- common libraries+import Control.Applicative import Language.Haskell.TH as TH import Language.Haskell.TH.Syntax as TH @@ -49,16 +50,28 @@ void :: e -> Annotated e void = (''() <:) --- Hints imply marshalling strategies, which include source and destination types for marshalling.+-- |Pretty print an annotated entity. --+annotatedShowQ :: Show e => Annotated e -> Q String+annotatedShowQ (e :> hint) = ((show e ++ " :> ") ++) <$> showQ hint+annotatedShowQ (Typed name) = return $ "Typed " ++ show name++-- |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 instance Hint Name where -- must be a type name haskellType = conT+ foreignType = const (return Nothing)+ showQ = return . show instance Hint (Q TH.Type) where haskellType = id+ foreignType = const (return Nothing)+ showQ = (show <$>) -- |Determine the Haskell type implied for the given annotated entity. --@@ -77,6 +90,12 @@ show (TH.ppr nonVarInfo) } }++-- |Determine the foreign type *directly* implied for the given annotated entity if any.+--+foreignTypeOf :: Annotated e -> Q (Maybe QC.Type)+foreignTypeOf (_ :> hint) = foreignType hint+foreignTypeOf (Typed name) = return Nothing -- |Remove the annotation. --
Language/C/Inline/ObjC.hs view
@@ -14,25 +14,34 @@ module Language.C.Inline.ObjC ( -- * Re-export types from 'Foreign.C'- module Foreign.C.Types, CString, CStringLen, CWString, CWStringLen, Errno,+ module Foreign.C.Types, CString, CStringLen, CWString, CWStringLen, Errno, ForeignPtr, castForeignPtr, + -- * Re-export types from Template Haskell+ Name,+ -- * Combinators for inline Objective-C - objc_import, objc_interface, objc_implementation, objc, objc_emit,+ objc_import, objc_interface, objc_implementation, objc_record, objc_marshaller, objc_typecheck, objc, objc_emit, -- * Marshalling annotations- Annotated(..), (<:), void+ Annotated(..), (<:), void, Class(..), IsType,++ -- * Property maps+ PropertyAccess, (==>), (-->) ) where -- common libraries import Control.Applicative import Control.Monad hiding (void) import Data.Array+import Data.Char import Data.Dynamic import Data.IORef import Data.List+import Data.Maybe import Foreign.C as C import Foreign.C.String as C import Foreign.C.Types+import Foreign.ForeignPtr as C import Foreign.Marshal as C hiding (void) import Language.Haskell.TH as TH import Language.Haskell.TH.Syntax as TH@@ -48,6 +57,8 @@ import Language.C.Inline.Error import Language.C.Inline.Hint import Language.C.Inline.State+import Language.C.Inline.TH+import Language.C.Inline.ObjC.Hint import Language.C.Inline.ObjC.Marshal @@ -105,10 +116,17 @@ ; (tvs, argTys, inIO, resTy) <- splitHaskellType <$> haskellTypeOf ann_var -- Determine C types- ; cArgTys <- mapM (haskellTypeToCType ObjC) argTys- ; cResTy <- haskellTypeToCType ObjC resTy+ ; maybe_cArgTys <- mapM (haskellTypeToCType ObjC) argTys+ ; maybe_cResTy <- haskellTypeToCType ObjC resTy+ ; let cannotMapAllTypes = Nothing `elem` (maybe_cResTy : maybe_cArgTys)+ cArgTys = map maybeErrorCtype maybe_cArgTys+ cResTy = maybeErrorCtype maybe_cResTy+ + ; if cannotMapAllTypes + then do {str <- annotatedShowQ ann_var; reportErrorWithLang ObjC $ "invalid marshalling: " ++ str}+ else do - -- Determine the bridging type and the marshalling code+ { -- Determine the bridging type and the marshalling code ; (bridgeArgTys, cBridgeArgTys, hsArgMarshallers, cArgMarshallers) <- unzip4 <$> zipWithM generateCToHaskellMarshaller argTys cArgTys ; (bridgeResTy, cBridgeResTy, hsResMarshaller, cResMarshaller) <- generateHaskellToCMarshaller resTy cResTy@@ -145,7 +163,7 @@ |] ++ map makeStaticFunc wrapperDef- }+ } } splitHaskellType (ForallT tvs _ctxt ty) -- collect quantified variables (drop the context) = let (tvs', args, inIO, res) = splitHaskellType ty@@ -170,13 +188,225 @@ addStatic (AntiTypeDeclSpec st tqs ts loc) = AntiTypeDeclSpec (Tstatic loc:st) tqs ts loc addStatic declSpec = declSpec +maybeErrorCtype :: Maybe QC.Type -> QC.Type +maybeErrorCtype Nothing = [cty| typename __UNDEFINED_TYPE |] -- placeholder to make progress in the face of errors+maybeErrorCtype (Just ty) = ty+ forExpD :: Callconv -> String -> Name -> TypeQ -> DecQ forExpD cc str n ty- = do- { ty' <- ty- ; return $ ForeignD (ExportF cc str n ty')- }+ = do+ { ty' <- ty+ ; return $ ForeignD (ExportF cc str n ty')+ } +-- |Maps a quoted property to a quoted projection and a quoted update function in addition to the type of the projected+-- value.+--+data PropertyAccess = QC.ObjCIfaceDecl :==> (TH.TypeQ, TH.ExpQ, TH.ExpQ)++-- |Map a property to explicit projection and update functions.+--+(==>) = (:==>)++-- |Map a property to a field label. This function assumes that the field name is typed and can be reified.+--+(-->) :: QC.ObjCIfaceDecl -> Name -> PropertyAccess+prop --> fieldName = prop ==> (fieldTy, + [| $(varE fieldName) |], + [| \s v -> $(recUpdE [|s|] [do { vE <- [|v|]; return (fieldName, vE) }]) |])+ where+ fieldTy+ = do+ { info <- reify fieldName+ ; case info of+ VarI _ (ArrowT `AppT` _ `AppT` resTy) _ _ -> return resTy+ nonVarInfo -> + do+ { reportErrorAndFail QC.ObjC $ + "expected '" ++ show fieldName ++ "' to be a typed record field name, but it is " ++ + show (TH.ppr nonVarInfo)+ }+ }++-- |Specification of a bridge for a Haskell structure that can be queried and updated from Objective-C.+--+-- The first argument is the name of the Objective-C class that will be a proxy for the Haskell structure.+-- The second argument the name of the Haskell type of the bridged Haskell structure.+--+-- The generated class is immutable. When a property is updated, a new instance is allocated. This closely+-- mirrors the behaviour of the Haskell structure for which the class is a proxy.+--+-- The designated initialiser of the generated class is '[-initWith<HsName>HsPtr:(HsStablePtr)particleHsPtr]',+-- where '<HsName>' is the type name of the Haskell structure. This initialiser is generated if it is not+-- explicitly provided. The generated method '[-init]' calls the designated initialiser with 'nil' for the+-- stable pointer.+--+-- WARNING: This is a very experimental feature and it will SURELY change in the future!!!+--+--FIXME: don't generate the designated initialiser if it is explicitly provided+objc_record :: String -- ^prefix of the class name+ -> String -- ^class name+ -> TH.Name -- ^name of the Haskell type of the bridged Haskell structure+ -> [Annotated TH.Name] -- ^Haskell variables used in Objective-C code+ -> [PropertyAccess] -- ^Objective-C properties with corresponding Haskell projections and update functions+ -> [QC.ObjCIfaceDecl] -- ^extra interface declarations+ -> [QC.Definition] -- ^extra implementation declarations+ -> Q [TH.Dec]+objc_record prefix objcClassName hsTyName ann_vars properties ifaceDecls impDecls+ | null objcClassName+ = reportErrorAndFail ObjC "empty class name"+ | otherwise+ = do+ { -- Turn projection and update functions into Haskell top-level function definitions+ ; let (propTys, propProjFuns, propUpdFuns) = unzip3 [(ty, proj, upd) | (_ :==> (ty, proj, upd)) <- properties]+ ; projNames <- sequence [ return . mkName $ "proj" ++ objcClassName ++ show i | (_, i) <- zip propProjFuns [1..]]+ ; updNames <- sequence [ return . mkName $ "upd" ++ objcClassName ++ show i | (_, i) <- zip propProjFuns [1..]]+ ; let projUpd_defs = [ funD name [clause [] (normalB propFun) []] + | (name, propFun) <- zip projNames propProjFuns ++ zip updNames propUpdFuns]++ -- All new top-level functions are in the set of free variables for the implementation code+ ; let all_ann_vars = ann_vars ++ zipWith addProjType projNames propTys ++ zipWith addUpdType updNames propTys++ -- Construct the class interface+ ; let propertyDecls = [prop | (prop :==> _) <- properties]+ updateMethodDecls = concatMap mkUpdateMethodDecl propertyDecls+ iface = [cunit| + @interface $id:prefixedClassName : NSObject+ + $ifdecls:propertyDecls+ $ifdecls:updateMethodDecls+ $ifdecls:ifaceDecls+ + @end+ |]++ -- Construct the class implementation+ ; let updateMethodDefs = concat $ zipWith mkUpdateMethodDef propertyDecls updNames+ projectionMethodDefs = concat $ zipWith mkProjectionMethodDef propertyDecls projNames+ imp = [cunit|+ @interface $id:prefixedClassName ()+ @property (readonly, assign, nonatomic) typename HsStablePtr $id:hsPtrName;+ @end+ + @implementation $id:prefixedClassName+ + $edecls:updateMethodDefs+ $edecls:impDecls+ + - (instancetype)init+ {+ return [self $id:initWithHsPtrName:nil];+ }+ + - (instancetype)$id:initWithHsPtrName:(typename HsStablePtr)$id:hsPtrName+ {+ self = [super init];+ if (self)+ $id:("_" ++ hsPtrName) = $id:hsPtrName;+ return self;+ }+ + - (void)dealloc+ {+ hs_free_stable_ptr($id:("_" ++ hsPtrName));+ }++ $edecls:projectionMethodDefs++ @end+ |]+ + -- Inline the class interface and class implementation; then, return all new Haskell bindings+ ; iface_defs <- objc_interface iface+ ; imp_defs <- objc_implementation all_ann_vars imp+ ; fun_defs <- sequence projUpd_defs+ ; return $ iface_defs ++ imp_defs ++ fun_defs+ }+ where+ addProjType name ty = name :> [t| $(conT hsTyName) -> $ty |]+ addUpdType name ty = name :> [t| $(conT hsTyName) -> $ty -> $(conT hsTyName) |]+ + prefixedClassName = prefix ++ objcClassName+ lowerClassName = toLower (head objcClassName) : tail objcClassName+ hsTyNameBase = nameBase hsTyName+ lowerHsTyName = toLower (head hsTyNameBase) : tail hsTyNameBase+ hsPtrName = lowerHsTyName ++ "HsPtr"+ initWithHsPtrName = "initWith" ++ hsTyNameBase ++ "HsPtr"++ mkUpdateMethodDecl propDecl@(ObjCIfaceProp _attrs + (FieldGroup spec [Field (Just (Id propName _)) (Just decl) _exp _] loc)+ _)+ = [objcifdecls| + + (instancetype)$id:lowerClassName:(typename $id:prefixedClassName *)$id:lowerClassName + $id:("with" ++ upperPropName):($ty:propTy)$id:propName; + |]+ where+ upperPropName = toUpper (head propName) : tail propName+ propTy = QC.Type spec decl loc+ + mkUpdateMethodDef propDecl@(ObjCIfaceProp _attrs + (FieldGroup spec [Field (Just (Id propName _)) (Just decl) _exp _] loc)+ _)+ updName+ = [objcimdecls| + + (instancetype)$id:lowerClassName:(typename $id:prefixedClassName *)$id:lowerClassName + $id:("with" ++ upperPropName):($ty:propTy)$id:propName+ {+ return [[$id:prefixedClassName alloc] $id:initWithHsPtrName:$id:(show updName)($id:lowerClassName.$id:hsPtrName,+ $id:propName)];+ }+ |]+ where+ upperPropName = toUpper (head propName) : tail propName+ propTy = QC.Type spec decl loc++ mkProjectionMethodDef propDecl@(ObjCIfaceProp _attrs + (FieldGroup spec [Field (Just (Id propName _)) (Just decl) _exp _] loc)+ _)+ updName+ = [objcimdecls| + - ($ty:propTy)$id:propName+ {+ return $id:(show updName)(self.$id:hsPtrName);+ }+ |]+ where+ propTy = QC.Type spec decl loc++-- |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+ = do+ { -- check that the marshallers have compatible types+ ; (hsTy1, classTy1) <- argAndResultTy haskellToObjCName+ ; (classTy2, hsTy2) <- argAndResultTy objcToHaskellName+ ; unless (hsTy1 == hsTy2 && classTy1 == classTy2) $+ reportErrorAndFail QC.ObjC $ + "the two marshallers must map between the same types"+ + ; tyconName <- headTyConNameOrError QC.ObjC classTy1+ ; let cTy = [cty| typename $id:(nameBase tyconName) * |]+ ; stashMarshaller (hsTy1, classTy1, cTy, haskellToObjCName, objcToHaskellName)+ ; return []+ }+ where+ argAndResultTy name+ = do+ { info <- reify name+ ; case info of+ VarI _ (ArrowT `AppT` argTy `AppT` (ConT io `AppT` resTy)) _ _+ | io == ''IO+ -> return (argTy, resTy)+ VarI _ ty _ _ -> reportErrorAndFail QC.ObjC $ + show name ++ "'s type must match 'a -> IO r'"+ other -> reportErrorAndFail QC.ObjC $ + show name ++ " must be a function"+ }+ -- |Inline Objective-C expression. -- -- The inline expression will be wrapped in a C function whose arguments are marshalled versions of the Haskell@@ -192,10 +422,17 @@ ; resTy <- haskellTypeOf ann_e -- Determine C types- ; cArgTys <- mapM (haskellTypeToCType ObjC) varTys- ; cResTy <- haskellTypeToCType ObjC resTy-- -- Determine the bridging type and the marshalling code+ ; maybe_cArgTys <- mapM annotatedHaskellTypeToCType ann_vars+ ; maybe_cResTy <- annotatedHaskellTypeToCType ann_e+ ; let cannotMapAllTypes = Nothing `elem` (maybe_cResTy : maybe_cArgTys)+ cArgTys = map maybeErrorCtype maybe_cArgTys+ cResTy = maybeErrorCtype maybe_cResTy+ + ; if cannotMapAllTypes+ then failOn [ann_var | (ann_var, Nothing) <- zip ann_vars maybe_cArgTys] maybe_cResTy+ else do+ + { -- Determine the bridging type and the marshalling code ; (bridgeArgTys, cBridgeArgTys, hsArgMarshallers, cArgMarshallers) <- unzip4 <$> zipWithM generateHaskellToCMarshaller varTys cArgTys ; (bridgeResTy, cBridgeResTy, hsResMarshaller, cResMarshaller) <-@@ -205,7 +442,7 @@ ; let hsWrapperTy = haskellWrapperType [] bridgeArgTys bridgeResTy -- FFI setup for the C wrapper- ; cwrapperName <- newName "cwrapper"+ ; cwrapperName <- show <$> newName "cwrapper" >>= newName -- Don't ask... ; stashHS [ forImpD CCall Safe (show cwrapperName) cwrapperName hsWrapperTy ]@@ -222,7 +459,7 @@ -- Generate invocation of the C wrapper sandwiched into Haskell-side marshalling ; generateHSCall vars hsArgMarshallers (callThroughTable idx hsWrapperTy) hsResMarshaller True- }+ } } where callThroughTable idx ty = do { jumptable <- getForeignTable@@ -231,6 +468,27 @@ (error "InlineObjC: INTERNAL ERROR: type mismatch in jumptable") :: $ty |] }+ + failOn err_ann_vars maybe_cResTy+ = do+ { unless (null err_ann_vars) $ do+ { var_strs <- mapM annotatedShowQ err_ann_vars+ ; reportErrorWithLang ObjC $ "invalid marshalling: " ++ intercalate ", " var_strs+ }+ ; unless (isJust maybe_cResTy) $ do+ { ty <- haskellTypeOf ann_e+ ; reportErrorWithLang ObjC $ "invalid marshalling for result type " ++ show ty+ }+ ; [| error "error in inline Objective-C expression" |]+ }+ + annotatedHaskellTypeToCType ann_e+ = do+ { maybe_objcType <- foreignTypeOf ann_e+ ; case maybe_objcType of+ Nothing -> haskellTypeOf ann_e >>= haskellTypeToCType ObjC+ Just objcType -> return $ Just objcType+ } -- Turn a list of argument types and a result type into a Haskell wrapper signature. --@@ -284,10 +542,16 @@ -- cParams [a1, .., an] [v1, .., vn] = [[cparam| a1 v1 |], .., [cparam| an vn |]] --+-- * If the list is empty, we will return a singleton 'void' parameter.+-- cParams :: [QC.Type] -> [TH.Name] -> [QC.Param]-cParams [] [] = []-cParams (argTy:argTys) (var:vars) = [cparam| $ty:argTy $id:(show var) |] : cParams argTys vars+cParams [] [] = [ [cparam| void |] ]+cParams tys names = cParams' tys names+ where+ cParams' [] [] = []+ cParams' (argTy:argTys) (var:vars) = [cparam| $ty:argTy $id:(show var) |] : cParams' argTys vars + -- Produce a Haskell expression that calls a function with all arguments and the result marshalled with the supplied -- marshallers. --@@ -327,7 +591,8 @@ ; appendFile objcFname_h (unlines (map mkImport headers) ++ "\n") ; appendFile objcFname_h (show $ QC.ppr objc_h) ; writeFile objcFname_m (info origFname)- ; appendFile objcFname_m ("#import \"" ++ takeFileName objcFname_h ++ "\"\n\n")+ ; appendFile objcFname_m ("#import \"" ++ takeFileName objcFname_h ++ "\"\n")+ ; appendFile objcFname_m ("#import \"HsFFI.h\"\n\n") ; appendFile objcFname_m (show $ QC.ppr objc_m) } ; objc_jumptable <- getForeignTable@@ -348,3 +613,13 @@ info fname = "// Generated code: DO NOT EDIT\n\ \// generated from '" ++ fname ++ "'\n\ \// by package 'language-c-inline'\n\n"++-- |Force type checking of all declaration appearing earlier in this module.+-- +-- Template Haskell performs type checking on declaration groups seperated by toplevel splices. In order for a type+-- declaration to be available to an Objective-C inline directive, the type declaration must be in an earlier+-- declaration group than the Objective-C inline directive. A toplevel Objective-C inline directive always is the start+-- of a new declaration group; hence, it can be considered to be implicitly preceded by an 'objc_typecheck'.+--+objc_typecheck :: Q [TH.Dec]+objc_typecheck = return []
+ Language/C/Inline/ObjC/Hint.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE TemplateHaskell, GADTs, FlexibleInstances #-}++-- |+-- Module : Language.C.Inline.ObjC.Hint+-- Copyright : 2014 Manuel M T Chakravarty+-- License : BSD3+--+-- Maintainer : Manuel M T Chakravarty <chak@justtesting.org>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--+-- This module provides Objective-C specific hints.++module Language.C.Inline.ObjC.Hint (+ -- * Class hints+ Class(..), IsType+) where++ -- standard libraries+import Language.Haskell.TH as TH+import Language.Haskell.TH.Syntax as TH++ -- quasi-quotation libraries+import Language.C.Quote as QC+import Language.C.Quote.ObjC as QC++ -- friends+import Language.C.Inline.Error+import Language.C.Inline.Hint+import Language.C.Inline.TH+++-- |Class of entities that can be used as TH types.+--+class IsType ty where+ theType :: ty -> Q TH.Type++instance IsType TH.Type where+ theType = return++instance IsType (Q TH.Type) where+ theType = id++instance IsType TH.Name where+ theType name+ = do+ { info <- reify name+ ; case info of+ TyConI _ -> return $ ConT name+ PrimTyConI _ _ _ -> return $ ConT name + FamilyI _ _ -> return $ ConT name+ _ -> + do+ { reportErrorAndFail QC.ObjC $ + "expected '" ++ show name ++ "' to be a type name, but it is " ++ + show (TH.ppr info)+ }+ }+ +-- |Hint indicating to marshal an Objective-C object as a foreign pointer, where the argument is the Haskell type+-- representing the Objective-C class. The Haskell type name must coincide with the Objective-C class name.+--+data Class where+ Class :: IsType t => t -> Class++instance Hint Class where+ haskellType (Class tyish) + = do+ { ty <- theType tyish+ ; foreignWrapperDatacon ty -- FAILS if the declaration is not a 'ForeignPtr' wrapper+ ; return ty+ }+ foreignType (Class tyish)+ = do+ { name <- theType tyish >>= headTyConNameOrError QC.ObjC+ ; return $ Just [cty| typename $id:(nameBase name) * |]+ }+ showQ (Class tyish) + = do+ { ty <- theType tyish+ ; return $ "Class " ++ show ty+ }
Language/C/Inline/ObjC/Marshal.hs view
@@ -26,11 +26,13 @@ -- common libraries import Data.Map as Map+import Data.Maybe import Data.Word import Foreign.C as C import Foreign.C.String as C import Foreign.Marshal as C import Foreign.Ptr as C+import Foreign.ForeignPtr as C import Foreign.StablePtr as C import Language.Haskell.TH as TH import Language.Haskell.TH.Syntax as TH@@ -42,6 +44,8 @@ -- friends import Language.C.Inline.Error+import Language.C.Inline.State+import Language.C.Inline.TH -- Determine foreign types@@ -49,32 +53,44 @@ -- |Determine the C type that we map a given Haskell type to. ---haskellTypeToCType :: QC.Extensions -> TH.Type -> Q QC.Type-haskellTypeToCType lang (ForallT _tvs _ctxt ty) -- ignore quantifiers and contexts+haskellTypeToCType :: QC.Extensions -> TH.Type -> Q (Maybe QC.Type)+haskellTypeToCType lang (ForallT _tvs _ctxt ty) -- ignore quantifiers and contexts = haskellTypeToCType lang ty-haskellTypeToCType lang (ListT `AppT` (ConT char)) -- marshal '[Char]' as 'String'- | char == ''Char - = haskellTypeNameToCType lang ''String-haskellTypeToCType lang ty@(ConT maybeC `AppT` argTy) -- encode a 'Maybe' around a pointer type in the pointer- | maybeC == ''Maybe+haskellTypeToCType lang ty = do- { cargTy <- haskellTypeToCType lang argTy- ; if isCPtrType cargTy- then- return cargTy- else- unknownType lang ty+ { 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... }-haskellTypeToCType lang (ConT tc) -- nullary type constructors are delegated- = haskellTypeNameToCType lang tc-haskellTypeToCType lang ty@(VarT tv) -- can't marshal an unknown type- = unknownType lang ty-haskellTypeToCType lang ty@(UnboxedTupleT _) -- there is nothing like unboxed tuples in C- = unknownType lang ty-haskellTypeToCType _lang ty -- everything else is marshalled as a stable pointer- = return [cty| typename HsStablePtr |]+ where+ haskellTypeToCType' lang (ListT `AppT` (ConT char)) -- marshal '[Char]' as 'String'+ | char == ''Char + = haskellTypeNameToCType lang ''String+ haskellTypeToCType' lang ty@(ConT maybeC `AppT` argTy) -- encode a 'Maybe' around a pointer type in the pointer+ | maybeC == ''Maybe+ = do+ { cargTy <- haskellTypeToCType lang argTy+ ; if fmap isCPtrType cargTy == Just True+ then+ return cargTy+ else+ unknownType lang ty+ }+ haskellTypeToCType' lang (ConT tc) -- nullary type constructors are delegated+ = haskellTypeNameToCType lang tc+ haskellTypeToCType' lang ty@(VarT tv) -- can't marshal an unknown type+ = unknownType lang ty+ haskellTypeToCType' lang ty@(UnboxedTupleT _) -- there is nothing like unboxed tuples in C+ = unknownType lang ty+ haskellTypeToCType' _lang ty -- everything else is marshalled as a stable pointer+ = return $ Just [cty| typename HsStablePtr |] -unknownType lang ty = reportErrorAndFail lang $ "don't know a foreign type suitable for Haskell type '" ++ TH.pprint ty ++ "'"+ unknownType lang ty + = do+ { reportErrorWithLang lang $ "don't know a foreign type suitable for Haskell type '" ++ TH.pprint ty ++ "'"+ ; return Nothing+ } -- |Determine the C type that we map a given Haskell type constructor to — i.e., we map all Haskell types -- whose outermost constructor is the given type constructor to the returned C type.@@ -82,19 +98,22 @@ -- All types representing boxed values that are not explicitly mapped to a specific C type, are mapped to -- stable pointers. ---haskellTypeNameToCType :: QC.Extensions -> TH.Name -> Q QC.Type+haskellTypeNameToCType :: QC.Extensions -> TH.Name -> Q (Maybe QC.Type) haskellTypeNameToCType ext tyname = case Map.lookup tyname (haskellToCTypeMap ext) of- Just cty -> return cty+ Just cty -> return $ Just cty Nothing -> do { info <- reify tyname ; case info of PrimTyConI _ _ True -> unknownUnboxedType- _ -> return [cty| typename HsStablePtr |]+ _ -> return $ Just [cty| typename HsStablePtr |] } where- unknownUnboxedType = reportErrorAndFail ext $ - "don't know a foreign type suitable for the unboxed Haskell type '" ++ show tyname ++ "'" + unknownUnboxedType = do+ { reportErrorWithLang ext $ + "don't know a foreign type suitable for the unboxed Haskell type '" ++ show tyname ++ "'" + ; return Nothing+ } haskellToCTypeMap :: QC.Extensions -> Map TH.Name QC.Type haskellToCTypeMap ObjC@@ -104,9 +123,9 @@ , (''CUChar, [cty| unsigned char |]) , (''CShort, [cty| short |]) , (''CUShort, [cty| unsigned short |])- , (''Int, [cty| int |])+ , (''Int, [cty| typename NSInteger |]) , (''CInt, [cty| int |])- , (''Word, [cty| unsigned int |])+ , (''Word, [cty| typename NSUInteger |]) , (''CUInt, [cty| unsigned int |]) , (''CLong, [cty| long |]) , (''CULong, [cty| unsigned long |])@@ -118,6 +137,7 @@ , (''Double, [cty| double |]) , (''CDouble, [cty| double |]) --+ , (''Bool, [cty| typename BOOL |]) , (''String, [cty| typename NSString * |]) , (''(), [cty| void |]) ]@@ -161,33 +181,75 @@ -- * Generator for the Haskell-side marshalling code. -- * Generator for the C-side marshalling code. ---generateHaskellToCMarshaller :: TH.Type -> QC.Type -> Q (TH.TypeQ, QC.Type, HaskellMarshaller, CMarshaller)-generateHaskellToCMarshaller hsTy@(ConT maybe `AppT` argTy) cTy+generateHaskellToCMarshaller :: TH.Type -> QC.Type -> Q (TH.TypeQ, QC.Type, HaskellMarshaller, CMarshaller) +generateHaskellToCMarshaller hsTy cTy@(Type (DeclSpec _ _ (Tnamed (Id name _) _ _) _) (Ptr _ (DeclRoot _) _) _)+ | Just name == maybeHeadName -- wrapped ForeignPtr mapped to an Objective-C class+ = return ( ptrOfForeignPtrWrapper hsTy+ , cTy+ , \val cont -> [| C.withForeignPtr ($(unwrapForeignPtrWrapper hsTy) $val) $cont |]+ , \argName -> [cexp| $id:(show argName) |]+ )+ | otherwise+ = do+ { maybe_marshaller <- lookupMarshaller hsTy+ ; case maybe_marshaller of+ Just (_, classTy, cTy', haskellToC, _cToHaskell)+ | cTy' == cTy -- custom marshaller mapping to an Objective-C class+ -> return ( ptrOfForeignPtrWrapper classTy+ , cTy+ , \val cont -> [| do+ { nsClass <- $(varE haskellToC) $val+ ; C.withForeignPtr ($(unwrapForeignPtrWrapper classTy) nsClass) $cont+ } |]+ , \argName -> [cexp| $id:(show argName) |]+ )+ Nothing -- other => continue below+ -> generateHaskellToCMarshaller' hsTy cTy+ }+ where+ maybeHeadName = fmap nameBase $ headTyConName hsTy+generateHaskellToCMarshaller hsTy cTy = generateHaskellToCMarshaller' hsTy cTy++generateHaskellToCMarshaller' :: TH.Type -> QC.Type -> Q (TH.TypeQ, QC.Type, HaskellMarshaller, CMarshaller)+generateHaskellToCMarshaller' hsTy@(ConT maybe `AppT` argTy) cTy | maybe == ''Maybe && isCPtrType cTy = do { (argTy', cTy', hsMarsh, cMarsh) <- generateHaskellToCMarshaller argTy cTy ; ty <- argTy'- ; case ty of- ConT ptr `AppT` _ - | ptr == ''C.Ptr -> return ( argTy'- , cTy'- , \val cont -> [| case $val of- Nothing -> $cont C.nullPtr- Just val' -> $(hsMarsh [|val'|] cont) |] - , cMarsh- )- | ptr == ''C.StablePtr -> return ( argTy'- , cTy'- , \val cont -> [| case $val of- Nothing -> $cont (C.castPtrToStablePtr C.nullPtr)- Just val' -> $(hsMarsh [|val'|] cont) |]- -- NB: the above cast works for GHC, but is in the grey area- -- of the FFI spec- , cMarsh- )- _ -> reportErrorAndFail ObjC $ "missing 'Maybe' marshalling for '" ++ prettyQC cTy ++ "' to '" ++ TH.pprint hsTy ++ "'"+ ; resolve ty argTy' cTy' hsMarsh cMarsh }-generateHaskellToCMarshaller hsTy cTy+ where+ resolve ty argTy' cTy' hsMarsh cMarsh+ = case ty of+ ConT ptr `AppT` _ + | ptr == ''C.Ptr -> return ( argTy'+ , cTy'+ , \val cont -> [| case $val of+ Nothing -> $cont C.nullPtr+ Just val' -> $(hsMarsh [|val'|] cont) |] + , cMarsh+ )+ | ptr == ''C.StablePtr -> return ( argTy'+ , cTy'+ , \val cont -> [| case $val of+ Nothing -> $cont (C.castPtrToStablePtr C.nullPtr)+ Just val' -> $(hsMarsh [|val'|] cont) |]+ -- NB: the above cast works for GHC, but is in the grey area+ -- of the FFI spec+ , cMarsh+ )+ ConT con + -> do+ { info <- reify con+ ; case info of+ TyConI (TySynD _name [] tysyn) -> resolve tysyn argTy' cTy' hsMarsh cMarsh+ -- chase type synonyms (only nullary ones at the moment)+ _ -> missingErr+ }+ _ -> missingErr+ missingErr = reportErrorAndFail ObjC $ + "missing 'Maybe' marshalling for '" ++ prettyQC cTy ++ "' to '" ++ TH.pprint hsTy ++ "'"+generateHaskellToCMarshaller' hsTy cTy | Just hsMarshalTy <- Map.lookup cTy cIntegralMap -- checking whether it is an integral type = return ( hsMarshalTy , cTy@@ -200,11 +262,17 @@ , \val cont -> [| $cont (realToFrac $val) |] , \argName -> [cexp| $id:(show argName) |] )+ | cTy == [cty| typename BOOL |] + = return ( [t| C.CSChar |]+ , cTy+ , \val cont -> [| $cont (C.fromBool $val) |]+ , \argName -> [cexp| ($id:(show argName)) |]+ ) | cTy == [cty| typename NSString * |] = return ( [t| C.CString |] , [cty| char * |] , \val cont -> [| C.withCString $val $cont |]- , \argName -> [cexp| [NSString stringWithUTF8String: $id:(show argName)] |]+ , \argName -> [cexp| ($id:(show argName)) ? [NSString stringWithUTF8String: $id:(show argName)] : nil |] ) | cTy == [cty| typename HsStablePtr |] = return ( [t| C.StablePtr $(return hsTy) |]@@ -225,7 +293,79 @@ -- * Generator for the C-side marshalling code. -- generateCToHaskellMarshaller :: TH.Type -> QC.Type -> Q (TH.TypeQ, QC.Type, HaskellMarshaller, CMarshaller)-generateCToHaskellMarshaller hsTy cTy+generateCToHaskellMarshaller 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) } |] + }+ , \argName -> [cexp| $id:(show argName) |]+ )+ | otherwise+ = do+ { maybe_marshaller <- lookupMarshaller hsTy+ ; case maybe_marshaller of+ Just (_, classTy, cTy', _haskellToC, cToHaskell)+ | cTy' == cTy -- custom marshaller mapping to an Objective-C class+ -> return ( ptrOfForeignPtrWrapper classTy+ , cTy+ , \val cont -> do { let datacon = foreignWrapperDatacon classTy+ ; [| do + { fptr <- newForeignPtr_ $val+ ; hsVal <- $(varE cToHaskell) ($datacon fptr) + ; $cont hsVal+ } |] + }+ , \argName -> [cexp| $id:(show argName) |]+ )+ Nothing -- other => continue below+ -> generateCToHaskellMarshaller' hsTy cTy+ }+ where+ maybeHeadName = fmap nameBase $ headTyConName hsTy+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+ ; ty <- argTy'+ ; resolve ty argTy' cTy' hsMarsh cMarsh+ }+ where+ resolve ty argTy' cTy' hsMarsh cMarsh+ = case ty of+ ConT ptr `AppT` _ + | ptr == ''C.Ptr -> return ( argTy'+ , cTy'+ , \val cont -> [| if $val == C.nullPtr + then $cont Nothing + else $(hsMarsh val [| $cont . Just |]) |]+ , cMarsh+ )+ | ptr == ''C.StablePtr -> return ( argTy'+ , cTy'+ , \val cont -> [| if (C.castStablePtrToPtr $val) == C.nullPtr+ then $cont Nothing + else $(hsMarsh val [| $cont . Just |]) |]+ -- NB: the above cast works for GHC, but is in the grey area+ -- of the FFI spec+ , cMarsh+ )+ ConT con + -> do+ { info <- reify con+ ; case info of+ TyConI (TySynD _name [] tysyn) -> resolve tysyn argTy' cTy' hsMarsh cMarsh+ -- chase type synonyms (only nullary ones at the moment)+ _ -> missingErr+ }+ _ -> missingErr+ missingErr = reportErrorAndFail ObjC $ + "missing 'Maybe' marshalling for '" ++ prettyQC cTy ++ "' to '" ++ TH.pprint hsTy ++ "'"+generateCToHaskellMarshaller' hsTy cTy | Just hsMarshalTy <- Map.lookup cTy cIntegralMap -- checking whether it is an integral type = return ( hsMarshalTy , cTy@@ -238,6 +378,12 @@ , \val cont -> [| $cont (realToFrac $val) |] , \argName -> [cexp| $id:(show argName) |] )+ | cTy == [cty| typename BOOL |]+ = return ( [t| C.CSChar |]+ , cTy+ , \val cont -> [| $cont (C.toBool $val) |]+ , \argName -> [cexp| $id:(show argName) |]+ ) | cTy == [cty| typename NSString * |] = return ( [t| C.CString |] , [cty| char * |]@@ -246,12 +392,14 @@ let arg = show argName in [cexp|- ({ typename NSUInteger maxLen = [$id:arg maximumLengthOfBytesUsingEncoding:NSUTF8StringEncoding] + 1;- char *buffer = malloc (maxLen);- if (![$id:arg getCString:buffer maxLength:maxLen encoding:NSUTF8StringEncoding])- *buffer = '\0';- buffer;- })+ ( $id:arg )+ ? ({ typename NSUInteger maxLen = [$id:arg maximumLengthOfBytesUsingEncoding:NSUTF8StringEncoding] + 1;+ char *buffer = malloc (maxLen);+ if (![$id:arg getCString:buffer maxLength:maxLen encoding:NSUTF8StringEncoding])+ *buffer = '\0';+ buffer;+ })+ : nil |] ) | cTy == [cty| typename HsStablePtr |] @@ -270,17 +418,19 @@ = reportErrorAndFail ObjC $ "cannot marshall '" ++ prettyQC cTy ++ "' to '" ++ TH.pprint hsTy ++ "'" cIntegralMap = Map.fromList- [ ([cty| char |], [t| C.CChar |])- , ([cty| signed char |], [t| C.CChar |])- , ([cty| unsigned char |], [t| C.CUChar |])- , ([cty| short |], [t| C.CShort |])- , ([cty| unsigned short |], [t| C.CUShort |])- , ([cty| int |], [t| C.CInt |])- , ([cty| unsigned int |], [t| C.CUInt |])- , ([cty| long |], [t| C.CLong |])- , ([cty| unsigned long |], [t| C.CULong |])- , ([cty| long long |], [t| C.CLLong |])- , ([cty| unsigned long long |], [t| C.CULLong |])+ [ ([cty| char |], [t| C.CChar |])+ , ([cty| signed char |], [t| C.CChar |])+ , ([cty| unsigned char |], [t| C.CUChar |])+ , ([cty| short |], [t| C.CShort |])+ , ([cty| unsigned short |], [t| C.CUShort |])+ , ([cty| int |], [t| C.CInt |])+ , ([cty| unsigned int |], [t| C.CUInt |])+ , ([cty| long |], [t| C.CLong |])+ , ([cty| unsigned long |], [t| C.CULong |])+ , ([cty| long long |], [t| C.CLLong |])+ , ([cty| unsigned long long |], [t| C.CULLong |])+ , ([cty| typename NSInteger |], [t| Int |])+ , ([cty| typename NSUInteger |], [t| Word |]) ] cFloatingMap = Map.fromList
Language/C/Inline/State.hs view
@@ -16,9 +16,9 @@ State, -- * State query and update operations- setForeignTable, stashHeader, stashObjC_h, stashObjC_m, stashHS, + setForeignTable, stashHeader, stashMarshaller, stashObjC_h, stashObjC_m, stashHS, extendJumpTable,- getForeignTable, getForeignLabels, getHeaders, getHoistedObjC, getHoistedHS+ getForeignTable, getForeignLabels, getHeaders, getMarshallers, lookupMarshaller, getHoistedObjC, getHoistedHS ) where -- common libraries@@ -33,11 +33,18 @@ 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+ data State = State { foreignTable :: Q TH.Exp -- table of foreign labels , foreignLabels :: [Name] -- list of foreign imported names to populate 'foreignTable' , headers :: [String] -- imported Objective-C headers+ , marshallers :: [CustomMarshaller] -- User defined marshallers , hoistedObjC_h :: [QC.Definition] -- Objective-C that goes into the .h , hoistedObjC_m :: [QC.Definition] -- Objective-C that goes into the .m , hoistedHS :: [TH.Dec] -- Haskell that goes at the end of the module@@ -48,9 +55,10 @@ state = unsafePerformIO $ newIORef $ State- { foreignTable = error "InlineObjC: internal error: 'foreignTable' undefined"+ { foreignTable = error "Language.C.Inline.State: internal error: 'foreignTable' undefined" , foreignLabels = [] , headers = []+ , marshallers = [] , hoistedObjC_h = [] , hoistedObjC_m = [] , hoistedHS = []@@ -69,6 +77,9 @@ stashHeader :: String -> Q () stashHeader header = modifyState (\s -> s {headers = header : headers s}) +stashMarshaller :: CustomMarshaller -> Q ()+stashMarshaller marshaller = modifyState (\s -> s {marshallers = marshaller : marshallers s})+ stashObjC_h :: [QC.Definition] -> Q () stashObjC_h defs = modifyState (\s -> s {hoistedObjC_h = hoistedObjC_h s ++ defs}) @@ -97,6 +108,19 @@ getHeaders :: Q [String] getHeaders = reverse <$> readState headers++getMarshallers :: Q [CustomMarshaller]+getMarshallers = readState marshallers++lookupMarshaller :: TH.Type -> Q (Maybe CustomMarshaller)+lookupMarshaller ty+ = do+ { marshallers <- getMarshallers+ ; case filter (\(hsTy, _, _, _, _) -> hsTy == ty) marshallers of+ [] -> return Nothing+ marshaller:_ -> return $ Just marshaller+ }+ getHoistedObjC :: Q ([QC.Definition], [QC.Definition]) getHoistedObjC = (,) <$> readState hoistedObjC_h <*> readState hoistedObjC_m
+ Language/C/Inline/TH.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE TemplateHaskell, GADTs, FlexibleInstances #-}++-- |+-- Module : Language.C.Inline.TH+-- Copyright : 2014 Manuel M T Chakravarty+-- License : BSD3+--+-- Maintainer : Manuel M T Chakravarty <chak@justtesting.org>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--+-- This module provides Template Haskell convenience functions.++module Language.C.Inline.TH (+ -- * Decompose type expressions+ headTyConName, headTyConNameOrError,+ + -- * Decompose idiomatic declarations+ foreignWrapperDatacon, ptrOfForeignPtrWrapper, unwrapForeignPtrWrapper+) where++ -- standard libraries+import Control.Applicative+import Foreign.Ptr+import Foreign.ForeignPtr+import Language.Haskell.TH as TH+import Language.Haskell.TH.Syntax as TH++ -- quasi-quotation libraries+import Language.C.Quote as QC++ -- friends+import Language.C.Inline.Error+++-- |Project the name of the head of a type term if it is a type constructor.+--+headTyConName :: TH.Type -> Maybe TH.Name+headTyConName ty+ = case splitAppTy ty of+ (ConT name, _) -> Just name+ _ -> Nothing++-- |Like 'headTyConName', but fail if the head is not a type constructor.+--+headTyConNameOrError :: QC.Extensions -> TH.Type -> Q TH.Name+headTyConNameOrError lang ty+ = case headTyConName ty of+ Just name -> return name+ Nothing -> reportErrorAndFail lang $ "expected the head of '" ++ show ty ++ "' to be a type constructor"++-- |Decompose an n-ary type application into its head and arguments.+--+splitAppTy :: TH.Type -> (TH.Type, [TH.Type])+splitAppTy = split []+ where+ split args (ty `AppT` arg) = split (arg:args) ty+ split args (SigT ty _) = split args ty+ split args ty = (ty, args)++-- |Obtain the data constructor of the newtype in an idiomatic 'ForeignPtr' wrapper of the form+--+-- > newtype Wrapper <tvs> = Wrapper (ForeignPtr (Wrapper <tvs>))+--+foreignWrapperDatacon :: TH.Type -> Q TH.Exp+foreignWrapperDatacon ty+ = do + { (datacon, _) <- decomposeForeignPtrWrapper ty+ ; return $ ConE datacon+ }++-- |Unwraps a newtype wrapper around a foreign pointer and turns the 'ForeignPtr' into a 'Ptr'.+--+ptrOfForeignPtrWrapper :: TH.Type -> Q TH.Type+ptrOfForeignPtrWrapper ty = [t| Ptr $(snd <$> decomposeForeignPtrWrapper ty) |]++-- |Generate code that unwraps the foreign pointer inside the given foreign pointer wrapper type.+--+unwrapForeignPtrWrapper :: TH.Type -> Q TH.Exp+unwrapForeignPtrWrapper ty + = do+ { (datacon, _) <- decomposeForeignPtrWrapper ty+ ; v <- newName "v"+ ; [| \e -> $(caseE [| e |] [match (conP datacon [varP v]) (normalB $ varE v) []]) |]+ }++-- |Given a type whose head is a newtype wrapper around a foreign pointer of the form+--+-- > newtype Wrapper <tvs> = Wrapper (ForeignPtr (Wrapper <tvs>))+--+-- return the name of the wrapper data constructor and type argument of the 'ForeignPtr', where all '<tvs>' have been+-- substituted by the arguments in the type application constituting the input type (might be nullary).+--+decomposeForeignPtrWrapper :: TH.Type -> Q (TH.Name, TH.Type)+decomposeForeignPtrWrapper ty+ = do + { let (tycon, args) = splitAppTy ty+ ; name <- case tycon of+ ConT name -> return name+ _ -> + do+ { reportErrorAndFail QC.ObjC $ + "expected '" ++ show tycon ++ "' be a type constructor of a 'ForeignPtr' wrapper"+ }++ ; info <- reify name+ ; case info of+ TyConI (NewtypeD [] _name tvs (NormalC dataconName [(_strict, ConT fptr `AppT` ptrArg)]) _deriv) + | fptr == ''ForeignPtr+ -> return (dataconName, substitute (zip args tvs) ptrArg)+ nonForeign -> + do+ { reportErrorAndFail QC.ObjC $ + "expected '" ++ show name ++ "' to refer to a 'ForeignPtr' wrapped into a newtype, but it is " ++ + show (TH.ppr nonForeign)+ }+ }+ where+ substitute :: [(TH.Type, TH.TyVarBndr)] -> TH.Type -> TH.Type+ substitute subst (ForallT boundTvs cxt body)+ = ForallT boundTvs (substituteCxt subst' cxt) (substitute subst' body)+ where+ subst' = filter (`notShadowedBy` map theTV boundTvs) subst+ --+ (_, tv) `notShadowedBy` boundTvs = theTV tv `notElem` boundTvs+ --+ theTV (PlainTV tv) = tv+ theTV (KindedTV tv _) = tv+ substitute subst (t1 `AppT` t2)+ = (substitute subst t1) `AppT` (substitute subst t2)+ substitute subst (SigT ty ki)+ = SigT (substitute subst ty) ki+ substitute subst (VarT tv)+ = substituteName subst tv+ substitute _subst ty+ = ty+ + substituteCxt subst cxt = map (substitutePred subst) cxt+ + substitutePred subst (ClassP name tys) = ClassP name (map (substitute subst) tys)+ substitutePred subst (EqualP ty1 ty2) = EqualP (substitute subst ty1) (substitute subst ty2)+ + substituteName [] tv = VarT tv+ substituteName ((arg, tv):args) thisTv+ | tv `matches` thisTv = arg+ | otherwise = VarT thisTv+ + PlainTV name `matches` thisTv = name == thisTv+ KindedTV name _ki `matches` thisTv = name == thisTv
README.md view
@@ -10,7 +10,7 @@ To build the library, just use `cabal install` as usual from the source code directory or by installing from Hackage. -You may like to have a look at a [minimal example](blob/master/tests/objc/minimal/Main.hs) of its use, which you can build as follows:+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: * Execute `cd tests/objc/minimal; make`. * Now run the demo executable with `./Minimal`.
language-c-inline.cabal view
@@ -1,5 +1,5 @@ Name: language-c-inline-Version: 0.6.0.0+Version: 0.7.6.0 Cabal-version: >= 1.9.2 Tested-with: GHC == 7.6.3, GHC == 7.8.2 Build-type: Simple@@ -16,20 +16,25 @@ . Known bugs: <https://github.com/mchakravarty/language-c-inline/issues> .- * New in 0.6.0.0: Introduction of explicit marshalling hints (for more flexibility and support of+ * New in 0.7.6: (1) Record marshalling; (2) foreign pointer-class marshalling; (3) custom type+ marshallers. Generated _objc.m files now always include "HsFFI.h" (as the tool can generate type names+ declared in that header). Marshals 'Bool' as 'BOOL'. Marshal 'Int' and 'Word' to 'NSInteger' and+ 'NSUInteger', respectively.+ .+ * New in 0.6.0: Introduction of explicit marshalling hints (for more flexibility and support of GHC 7.8's untyped Template Haskell quotations) .- * New in 0.5.0.0: Marshalling of numeric types+ * New in 0.5.0: Marshalling of numeric types .- * New in 0.4.0.0: Maybe types are marshalled as pointers that may be nil & bug fixes.+ * New in 0.4.0: Maybe types are marshalled as pointers that may be nil & bug fixes. .- * New in 0.3.0.0: Boxed Haskell types without a dedicated type mapping are marshalled using stable+ * New in 0.3.0: Boxed Haskell types without a dedicated type mapping are marshalled using stable pointers. .- * New in 0.2.0.0: Support for multiple free variables in one inline expression as well+ * New in 0.2.0: Support for multiple free variables in one inline expression as well as for inline code returning 'void'. .- * New in 0.1.0.0: We are just getting started! This is just a ROUGH AND+ * New in 0.1.0: We are just getting started! This is just a ROUGH AND HIGHLY EXPERIMENTAL PROTOTYPE. License: BSD3 License-file: LICENSE@@ -73,7 +78,7 @@ base >= 4.0 && < 5, containers >= 0.4, filepath >= 1.2,- language-c-quote >= 0.7,+ language-c-quote >= 0.8, mainland-pretty >= 0.2.5, template-haskell @@ -82,6 +87,8 @@ Other-modules: Language.C.Inline.Error Language.C.Inline.Hint Language.C.Inline.State+ Language.C.Inline.TH+ Language.C.Inline.ObjC.Hint Language.C.Inline.ObjC.Marshal Extensions: TemplateHaskell, QuasiQuotes
tests/objc/app/AppDelegate.hs view
@@ -13,7 +13,7 @@ -- friends import Interpreter -objc_import ["<Cocoa/Cocoa.h>", "HsFFI.h"]+objc_import ["<Cocoa/Cocoa.h>"] -- Haskell code used from Objective-C.
tests/objc/concept/Makefile view
@@ -1,4 +1,6 @@ HC = ghc+LIBDIR = $(shell $(HC) --print-libdir)+CFLAGS = -fobjc-arc -I$(LIBDIR)/include -I$(LIBDIR)/../../includes HCFLAGS = LDFLAGS = -package template-haskell -package language-c-quote -package language-c-inline -framework Foundation
tests/objc/minimal/Makefile view
@@ -1,4 +1,6 @@ HC = ghc+LIBDIR = $(shell $(HC) --print-libdir)+CFLAGS = -fobjc-arc -I$(LIBDIR)/include -I$(LIBDIR)/../../includes HCFLAGS = LDFLAGS = -package template-haskell -package language-c-quote -package language-c-inline -framework Foundation
tests/objc/record/Particle.hs view
@@ -8,7 +8,7 @@ import Language.C.Quote.ObjC import Language.C.Inline.ObjC -objc_import ["<Foundation/Foundation.h>", "HsFFI.h"]+objc_import ["<Foundation/Foundation.h>"] -- Haskell code used from Objective-C.@@ -31,66 +31,23 @@ newParticle :: Float -> Particle newParticle mass = Particle mass origin zero zero -particleMass :: Particle -> Float-particleMass = mass---objc_interface [cunit|--@interface Particle : NSObject--@property (readonly) float mass;--+ (typename instancetype)particleWithMass:(float)mass;--- (typename instancetype)init;--- (typename instancetype)initWithMass:(float)mass;---@end-|]---objc_implementation [Typed 'newParticle, Typed 'particleMass] [cunit|--@interface Particle ()--@property (readonly, assign, nonatomic) typename HsStablePtr particle;--@end--@implementation Particle--// Initialisation--+ (typename instancetype)particleWithMass:(float)mass-{- return [[Particle alloc] initWithMass:mass];-}--- (typename instancetype)init-{- return [self initWithMass:0.0];-}--- (typename instancetype)initWithMass:(float)mass-{- self = [super init];- if (self)- _particle = newParticle(mass);- return self;-}--// Getters and setters--- (float)mass-{- return particleMass(self.particle);-}--@end-|]-+objc_record "" "Particle" ''Particle [Typed 'newParticle]+ [ [objcprop| @property (readonly) float mass; |] --> 'mass+ , [objcprop| @property (readonly) float locX; |] ==> ([t| Float |], + [| fst . loc |], + [| \p locX -> p { loc = (locX, snd . loc $ p) } |])+ , [objcprop| @property (readonly) float locY; |] ==> ([t| Float |], + [| snd . loc |], + [| \p locY -> p { loc = (fst . loc $ p, locY) } |])+ ]+ [objcifdecls|+ + (instancetype)particleWithMass:(float)mass;+ |] + [objcimdecls|+ + (instancetype)particleWithMass:(float)mass+ {+ return [[Particle alloc] initWithParticleHsPtr:newParticle(mass)];+ }+ |] objc_emit