module Language.C.Inline.ObjC (
module Foreign.C.Types, CString, CStringLen, CWString, CWStringLen, Errno, ForeignPtr, castForeignPtr,
Name,
objc_retain, objc_release, objc_release_ptr, newForeignClassPtr, newForeignStructPtr,
objc_import, objc_interface, objc_implementation, objc_record, objc_marshaller, objc_class_marshaller,
objc_struct_marshaller, objc_typecheck, objc, objc_emit,
Annotated(..), (<:), void, Class(..), Struct(..), IsType,
PropertyAccess, (==>), (-->)
) where
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
import System.FilePath
import System.IO.Unsafe (unsafePerformIO)
import Language.C.Quote as QC
import Language.C.Quote.ObjC as QC
import Text.PrettyPrint.Mainland as QC
import Text.PrettyPrint.Mainland.Class as QC
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
objc_import :: [FilePath] -> Q [TH.Dec]
objc_import headers
= do
{
; initialiseState
; mapM_ stashHeader headers
; objc_jumptable <- newName "objc_jumptable"
; setForeignTable $ varE objc_jumptable
; sequence $ [ sigD objc_jumptable [t|IORef (Array Int Dynamic)|]
, pragInlD objc_jumptable NoInline FunLike AllPhases
, valD (varP objc_jumptable) (normalB [|unsafePerformIO $ newIORef (array (0, 0) [])|]) []
]
}
objc_interface :: [QC.Definition] -> Q [TH.Dec]
objc_interface defs
= do
{ stashObjC_h defs
; return []
}
objc_implementation :: [Annotated TH.Name] -> [QC.Definition] -> Q [TH.Dec]
objc_implementation ann_vars defs
= do
{ mapM_ exportVar ann_vars
; stashObjC_m defs
; return []
}
where
exportVar ann_var
= do
{
; let var = stripAnnotation ann_var
; (tvs, argTys, inIO, resTy) <- splitHaskellType <$> haskellTypeOf ann_var
; 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
{
; (bridgeArgTys, cBridgeArgTys, hsArgMarshallers, cArgMarshallers) <-
unzip4 <$> zipWithM (generateCToHaskellMarshaller Nothing) argTys cArgTys
; (bridgeResTy, cBridgeResTy, hsResMarshaller, cResMarshaller) <- generateHaskellToCMarshaller resTy cResTy
; let hsWrapperTy = haskellWrapperType tvs bridgeArgTys bridgeResTy
; let cwrapperName = mkName . nameBase $ var
; hswrapperName <- newName (nameBase var ++ "_hswrapper")
; hsArgVars <- mapM (const $ newName "arg") bridgeArgTys
; stashHS
[ forExpD CCall (show hswrapperName) hswrapperName hsWrapperTy
, sigD hswrapperName hsWrapperTy
, funD hswrapperName
[ clause (map varP hsArgVars)
(normalB $ generateHSCall hsArgVars hsArgMarshallers (varE var) hsResMarshaller inIO)
[]
]
]
; cArgVars <- mapM (\n -> newName $ "arg" ++ show n) [1..length cBridgeArgTys]
; let cArgVarExps = [ [cexp| $id:(nameBase var) |] | var <- cArgVars]
call = [cexp| $id:(show hswrapperName) ( $args:cArgVarExps ) |]
(_wrapperProto, wrapperDef)
= generateCWrapper cwrapperName cBridgeArgTys cArgVars cArgMarshallers cArgTys cArgVars
call
resTy cBridgeResTy cResMarshaller cResTy
; stashObjC_m $
[cunit|
$ty:cBridgeResTy $id:(show hswrapperName) ($params:(cParams cBridgeArgTys cArgVars));
|]
++
map makeStaticFunc wrapperDef
} }
splitHaskellType (ForallT tvs _ctxt ty)
= let (tvs', args, inIO, res) = splitHaskellType ty
in
(tvs ++ tvs', args, inIO, res)
splitHaskellType (ArrowT `AppT` arg `AppT` res)
= let (tvs, args, inIO, res') = splitHaskellType res
in
(tvs, arg:args, inIO, res')
splitHaskellType (ConT io `AppT` res) | io == ''IO
= ([], [], True, res)
splitHaskellType res
= ([], [], False, res)
makeStaticFunc (FuncDef (Func dspec f decl ps body loc1) loc2)
= FuncDef (Func (addStatic dspec) f decl ps body loc1) loc2
makeStaticFunc (FuncDef (OldFunc dspec f decl ps ig body loc1) loc2)
= FuncDef (OldFunc (addStatic dspec) f decl ps ig body loc1) loc2
makeStaticFunc def = def
addStatic (DeclSpec st tqs ts loc) = DeclSpec (Tstatic loc:st) tqs ts loc
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 |]
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')
}
data PropertyAccess = QC.ObjCIfaceDecl :==> (TH.TypeQ, TH.ExpQ, TH.ExpQ)
(==>) = (:==>)
(-->) :: 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)
}
}
objc_record :: String
-> String
-> TH.Name
-> [Annotated TH.Name]
-> [PropertyAccess]
-> [QC.ObjCIfaceDecl]
-> [QC.Definition]
-> Q [TH.Dec]
objc_record prefix objcClassName hsTyName ann_vars properties ifaceDecls impDecls
| null objcClassName
= reportErrorAndFail ObjC "empty class name"
| otherwise
= do
{
; 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]
; let all_ann_vars = ann_vars ++ zipWith addProjType projNames propTys ++ zipWith addUpdType updNames propTys
; let propertyDecls = [prop | (prop :==> _) <- properties]
updateMethodDecls = concatMap mkUpdateMethodDecl propertyDecls
iface = [cunit|
@interface $id:prefixedClassName : NSObject
$ifdecls:propertyDecls
$ifdecls:updateMethodDecls
$ifdecls:ifaceDecls
@end
|]
; 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
|]
; 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
objc_marshaller :: TH.Name -> TH.Name -> Q [TH.Dec]
objc_marshaller = objc_class_marshaller
objc_class_marshaller :: TH.Name -> TH.Name -> Q [TH.Dec]
objc_class_marshaller = objc_marshaller' 'newForeignClassPtr
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
{
; (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, newForeignPtrFun)
; 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"
}
objc :: [Annotated TH.Name] -> Annotated QC.Exp -> Q TH.Exp
objc ann_vars ann_e
= do
{
; let vars = map stripAnnotation ann_vars
; varTys <- mapM haskellTypeOf ann_vars
; resTy <- haskellTypeOf ann_e
; newFP <- newForeignPtrOf ann_e
; 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
{
; (bridgeArgTys, cBridgeArgTys, hsArgMarshallers, cArgMarshallers) <-
unzip4 <$> zipWithM generateHaskellToCMarshaller varTys cArgTys
; (bridgeResTy, cBridgeResTy, hsResMarshaller, cResMarshaller) <-
generateCToHaskellMarshaller newFP resTy cResTy
; let hsWrapperTy = haskellWrapperType [] bridgeArgTys bridgeResTy
; loc <- location
; let modName = dropExtension . takeFileName . loc_filename $ loc
; cwrapperName <- show <$> newName ("cwrapper_" ++ modName) >>= newName
; stashHS
[ forImpD CCall Safe (show cwrapperName) cwrapperName hsWrapperTy
]
; idx <- extendJumpTable cwrapperName
; cArgVars <- mapM (newName . nameBase) vars
; let (wrapperProto, wrapperDef)
= generateCWrapper cwrapperName cArgTys vars cArgMarshallers cBridgeArgTys cArgVars
(stripAnnotation ann_e)
resTy cResTy cResMarshaller cBridgeResTy
; stashObjC_h wrapperProto
; stashObjC_m wrapperDef
; generateHSCall vars hsArgMarshallers (callThroughTable idx hsWrapperTy) hsResMarshaller True
} }
where
callThroughTable idx ty
= do { jumptable <- getForeignTable
; [|fromDyn
((unsafePerformIO $ readIORef $jumptable) ! $(TH.lift idx))
(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
}
haskellWrapperType :: [TH.TyVarBndr] -> [TH.TypeQ] -> TH.TypeQ -> TH.TypeQ
haskellWrapperType [] argTys resTy = wrapperBodyType argTys resTy
haskellWrapperType tvs argTys resTy = forallT tvs (cxt []) (wrapperBodyType argTys resTy)
wrapperBodyType :: [TH.TypeQ] -> TH.TypeQ -> TH.TypeQ
wrapperBodyType [] resTy = [t| IO $resTy |]
wrapperBodyType (argTy:argTys) resTy = [t| $argTy -> $(wrapperBodyType argTys resTy) |]
generateCWrapper :: TH.Name
-> [QC.Type]
-> [TH.Name]
-> [CMarshaller]
-> [QC.Type]
-> [TH.Name]
-> QC.Exp
-> TH.Type
-> QC.Type
-> CMarshaller
-> QC.Type
-> ([QC.Definition], [QC.Definition])
generateCWrapper cwrapperName argTys vars argMarshallers cWrapperArgTys argVars e hsResTy resTy resMarshaller cWrapperResTy
= let cMarshalling = [ [citem| $ty:argTy $id:(nameBase var) = $exp:(argMarshaller argVar); |]
| (argTy, var, argMarshaller, argVar) <- zip4 argTys vars argMarshallers argVars]
resultName = mkName "result"
cInvocation | hsResTy == (ConT ''()) = [citem| $exp:e; |]
| otherwise = [citem| {
$ty:resTy $id:(show resultName) = $exp:e; // nonvoid result...
return $exp:(resMarshaller resultName); // ...marshalled to Haskell
}|]
in
([cunit|
$ty:cWrapperResTy $id:(show cwrapperName) ($params:(cParams cWrapperArgTys argVars));
|],
[cunit|
$ty:cWrapperResTy $id:(show cwrapperName) ($params:(cParams cWrapperArgTys argVars))
{
$items:cMarshalling
$item:cInvocation
}
|])
cParams :: [QC.Type] -> [TH.Name] -> [QC.Param]
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
generateHSCall :: [TH.Name]
-> [HaskellMarshaller]
-> TH.ExpQ
-> HaskellMarshaller
-> Bool
-> TH.ExpQ
generateHSCall vars hsArgMarshallers f hsResMarshaller inIO
= invoke [hsArgMarshaller (varE var) | (var, hsArgMarshaller) <- zip vars hsArgMarshallers]
f
(if inIO then [| \call -> do { cresult <- call ; $(hsResMarshaller [|cresult|] [|return|]) } |]
else [| \call -> do { let {cresult = call}; $(hsResMarshaller [|cresult|] [|return|]) } |])
where
invoke :: [TH.ExpQ -> TH.ExpQ] -> TH.ExpQ -> TH.ExpQ -> TH.ExpQ
invoke [] call ret = [| $ret $call |]
invoke (arg:args) call ret = arg [| \name -> $(invoke args [| $call name |] ret)|]
objc_emit :: Q [TH.Dec]
objc_emit
= do
{ loc <- location
; let origFname = loc_filename loc
objcFname = dropExtension origFname ++ "_objc"
objcFname_h = objcFname `addExtension` "h"
objcFname_m = objcFname `addExtension` "m"
; allHeaders <- getHeaders
; (objc_h, objc_m) <- getHoistedObjC
; let (hsFFIHeader, headers) = separateHsFFI allHeaders
; runIO $
do
{ writeFile objcFname_h (info origFname)
; appendFile objcFname_h (unlines (map mkImport headers) ++ "\n")
; appendFile objcFname_h (pretty 80 $ QC.ppr objc_h)
; writeFile objcFname_m (info origFname)
; appendFile objcFname_m ("#import \"" ++ takeFileName objcFname_h ++ "\"\n")
; appendFile objcFname_m (mkImport hsFFIHeader ++ "\n\n")
; appendFile objcFname_m (pretty 80 $ QC.ppr objc_m)
}
; objc_jumptable <- getForeignTable
; labels <- getForeignLabels
; initialize <- [d|objc_initialise :: IO ()
objc_initialise
=
writeIORef $objc_jumptable $
listArray ($(lift (1::Int)), $(lift $ length labels)) $
$(listE [ [|toDyn $(varE label)|] | label <- labels])
|]
; (initialize ++) <$> getHoistedHS
}
where
hsFFI = "HsFFI.h"
separateHsFFI headers
= case break ((== hsFFI) . takeFileName) headers of
(before, []) -> (hsFFI, before)
(before, ffi:after) -> (ffi, before ++ after)
mkImport h@('<':_) = "#import " ++ h ++ ""
mkImport h = "#import \"" ++ h ++ "\""
info fname = "// Generated code: DO NOT EDIT\n\
\// generated from '" ++ fname ++ "'\n\
\// by package 'language-c-inline'\n\n"
objc_typecheck :: Q [TH.Dec]
objc_typecheck = return []