module Language.C.Inline.ObjC (
module Foreign.C.Types, CString, CStringLen, CWString, CWStringLen, Errno,
objc_import, objc_interface, objc_implementation, objc, objc_emit
) where
import Control.Applicative
import Control.Monad
import Data.Array
import Data.Dynamic
import Data.IORef
import Data.List
import Foreign.C as C
import Foreign.C.String as C
import Foreign.C.Types
import Foreign.Marshal as C
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 Language.C.Inline.Error
import Language.C.Inline.State
import Language.C.Inline.ObjC.Marshal
objc_import :: [FilePath] -> Q [TH.Dec]
objc_import headers
= do
{ 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 :: [TH.Name] -> [QC.Definition] -> Q [TH.Dec]
objc_implementation vars defs
= do
{ mapM_ exportVar vars
; stashObjC_m defs
; return []
}
where
exportVar var
= do
{
; (tvs, argTys, inIO, resTy) <- splitHaskellType <$> determineVarType var
; cArgTys <- mapM (haskellTypeToCType ObjC) argTys
; cResTy <- haskellTypeToCType ObjC resTy
; (bridgeArgTys, cBridgeArgTys, hsArgMarshallers, cArgMarshallers) <-
unzip4 <$> zipWithM generateCToHaskellMarshaller 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
forExpD :: Callconv -> String -> Name -> TypeQ -> DecQ
forExpD cc str n ty
= do
{ ty' <- ty
; return $ ForeignD (ExportF cc str n ty')
}
objc :: [TH.Name] -> TH.Name -> QC.Exp -> Q TH.Exp
objc vars resTy e
= do
{
; varTys <- mapM determineVarType vars
; checkTypeName resTy
; cArgTys <- mapM (haskellTypeToCType ObjC) varTys
; cResTy <- haskellTypeNameToCType ObjC resTy
; (bridgeArgTys, cBridgeArgTys, hsArgMarshallers, cArgMarshallers) <-
unzip4 <$> zipWithM generateHaskellToCMarshaller varTys cArgTys
; (bridgeResTy, cBridgeResTy, hsResMarshaller, cResMarshaller) <-
generateCToHaskellMarshaller (ConT resTy) cResTy
; let hsWrapperTy = haskellWrapperType [] bridgeArgTys bridgeResTy
; cwrapperName <- newName "cwrapper"
; 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
e
(ConT 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 |]
}
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 [] [] = []
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"
; headers <- getHeaders
; (objc_h, objc_m) <- getHoistedObjC
; runIO $
do
{ writeFile objcFname_h (info origFname)
; 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 (show $ 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
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"