module Language.C.Inline.ObjC.Marshal (
objc_retain, objc_release, objc_release_ptr, newForeignClassPtr, newForeignStructPtr,
haskellTypeToCType,
HaskellMarshaller, CMarshaller,
generateHaskellToCMarshaller, generateCToHaskellMarshaller
) where
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
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.TH
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 ())
newForeignClassPtr :: C.Ptr a -> IO (C.ForeignPtr a)
newForeignClassPtr ptr = objc_retain ptr >>= newForeignPtr objc_release_ptr
newForeignStructPtr :: C.Ptr a -> IO (C.ForeignPtr a)
newForeignStructPtr ptr = newForeignPtr finalizerFree ptr
haskellTypeToCType :: QC.Extensions -> TH.Type -> Q (Maybe QC.Type)
haskellTypeToCType lang (ForallT _tvs _ctxt ty)
= haskellTypeToCType lang ty
haskellTypeToCType lang ty
= do
{ maybe_marshaller <- lookupMarshaller ty
; case maybe_marshaller of
Just (_, _, cTy, _, _, _) -> return $ Just cTy
Nothing -> haskellTypeToCType' lang ty
}
where
haskellTypeToCType' lang (ListT `AppT` (ConT char))
| char == ''Char
= haskellTypeNameToCType lang ''String
haskellTypeToCType' lang ty@(ConT maybeC `AppT` argTy)
| maybeC == ''Maybe
= do
{ cargTy <- haskellTypeToCType lang argTy
; if fmap isCPtrType cargTy == Just True
then
return cargTy
else
unknownType lang ty
}
haskellTypeToCType' lang ty@(ConT ptrC `AppT` argTy)
| ptrC == ''Ptr
= return $ Just [cty| void* |]
| ptrC == ''FunPtr
= return $ Just [cty| void*(void) |]
| ptrC == ''StablePtr
= return $ Just [cty| void*(void) |]
haskellTypeToCType' lang (ConT tc)
= haskellTypeNameToCType lang tc
haskellTypeToCType' lang ty@(VarT tv)
= unknownType lang ty
haskellTypeToCType' lang ty@(UnboxedTupleT _)
= unknownType lang ty
haskellTypeToCType' _lang ty
= return $ Just [cty| typename HsStablePtr |]
unknownType lang ty
= do
{ reportErrorWithLang lang $ "don't know a foreign type suitable for Haskell type '" ++ TH.pprint ty ++ "'"
; return Nothing
}
haskellTypeNameToCType :: QC.Extensions -> TH.Name -> Q (Maybe QC.Type)
haskellTypeNameToCType ext tyname
= case Map.lookup tyname (haskellToCTypeMap ext) of
Just cty -> return $ Just cty
Nothing -> do
{ info <- reify tyname
; case info of
PrimTyConI _ _ True -> unknownUnboxedType
_ -> return $ Just [cty| typename HsStablePtr |]
}
where
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
= Map.fromList
[ (''CChar, [cty| char |])
, (''CSChar, [cty| signed char |])
, (''CUChar, [cty| unsigned char |])
, (''CShort, [cty| short |])
, (''CUShort, [cty| unsigned short |])
, (''Int, [cty| typename NSInteger |])
, (''CInt, [cty| int |])
, (''Word, [cty| typename NSUInteger |])
, (''CUInt, [cty| unsigned int |])
, (''CLong, [cty| long |])
, (''CULong, [cty| unsigned long |])
, (''CLLong, [cty| long long |])
, (''CULLong, [cty| unsigned long long |])
, (''Float, [cty| float |])
, (''CFloat, [cty| float |])
, (''Double, [cty| double |])
, (''CDouble, [cty| double |])
, (''Bool, [cty| typename BOOL |])
, (''String, [cty| typename NSString * |])
, (''(), [cty| void |])
]
haskellToCTypeMap _lang
= Map.empty
isCPtrType :: QC.Type -> Bool
isCPtrType (Type _ (Ptr {}) _) = True
isCPtrType (Type _ (BlockPtr {}) _) = True
isCPtrType (Type _ (Array {}) _) = True
isCPtrType ty
| ty == [cty| typename HsStablePtr |] = True
| otherwise = False
type HaskellMarshaller = TH.ExpQ -> TH.ExpQ -> TH.ExpQ
type CMarshaller = TH.Name -> QC.Exp
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
= 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, _newForeignPtr)
| cTy' == cTy
-> return ( ptrOfForeignPtrWrapper classTy
, cTy
, \val cont -> [| do
{ nsClass <- $(varE haskellToC) $val
; C.withForeignPtr ($(unwrapForeignPtrWrapper classTy) nsClass) $cont
} |]
, \argName -> [cexp| $id:(show argName) |]
)
Nothing
-> 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'
; 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 -> [| 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) |]
, cMarsh
)
ConT con
-> do
{ info <- reify con
; case info of
TyConI (TySynD _name [] tysyn) -> resolve tysyn argTy' cTy' hsMarsh cMarsh
_ -> missingErr
}
_ -> missingErr
missingErr = reportErrorAndFail ObjC $
"missing 'Maybe' marshalling for '" ++ prettyQC cTy ++ "' to '" ++ TH.pprint hsTy ++ "'"
generateHaskellToCMarshaller' hsTy@(ConT ptrC `AppT` argTy) cTy
| ptrC == ''Ptr || ptrC == ''FunPtr || ptrC == ''StablePtr
= return ( return hsTy
, cTy
, \val cont -> [| $cont $val |]
, \argName -> [cexp| $id:(show argName) |]
)
generateHaskellToCMarshaller' hsTy cTy
| Just hsMarshalTy <- Map.lookup cTy cIntegralMap
= return ( hsMarshalTy
, cTy
, \val cont -> [| $cont (fromIntegral $val) |]
, \argName -> [cexp| $id:(show argName) |]
)
| Just hsMarshalTy <- Map.lookup cTy cFloatingMap
= return ( hsMarshalTy
, cTy
, \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| ($id:(show argName)) ? [NSString stringWithUTF8String: $id:(show argName)] : nil |]
)
| cTy == [cty| typename HsStablePtr |]
= return ( [t| C.StablePtr $(return hsTy) |]
, cTy
, \val cont -> [| do { C.newStablePtr $val >>= $cont } |]
, \argName -> [cexp| $id:(show argName) |]
)
| otherwise
= reportErrorAndFail ObjC $ "cannot marshal '" ++ TH.pprint hsTy ++ "' to '" ++ prettyQC cTy ++ "'"
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
= return ( ptrOfForeignPtrWrapper hsTy
, cTy
, \val cont -> do { let datacon = foreignWrapperDatacon hsTy
; [| do { fptr <- $(varE newForeignPtr) $val; $cont ($datacon fptr) } |]
}
, \argName -> [cexp| $id:(show argName) |]
)
where
maybeHeadName = fmap nameBase $ headTyConName hsTy
generateCToHaskellMarshaller Nothing
hsTy
cTy
= do
{ maybe_marshaller <- lookupMarshaller hsTy
; case maybe_marshaller of
Just (_, classTy, cTy', _haskellToC, cToHaskell, newForeignPtr)
| cTy' == cTy
-> return ( ptrOfForeignPtrWrapper classTy
, cTy
, \val cont -> do { let datacon = foreignWrapperDatacon classTy
; [| do
{ fptr <- $(varE newForeignPtr) $val
; hsVal <- $(varE cToHaskell) ($datacon fptr)
; $cont hsVal
} |]
}
, \argName -> [cexp| $id:(show argName) |]
)
Nothing
-> 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 Nothing 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 |]) |]
, cMarsh
)
ConT con
-> do
{ info <- reify con
; case info of
TyConI (TySynD _name [] tysyn) -> resolve tysyn argTy' cTy' hsMarsh cMarsh
_ -> missingErr
}
_ -> missingErr
missingErr = reportErrorAndFail ObjC $
"missing 'Maybe' marshalling for '" ++ prettyQC cTy ++ "' to '" ++ TH.pprint hsTy ++ "'"
generateCToHaskellMarshaller' hsTy@(ConT ptrC `AppT` argTy) cTy
| ptrC == ''Ptr || ptrC == ''FunPtr || ptrC == ''StablePtr
= return ( return hsTy
, cTy
, \val cont -> [| $cont $val |]
, \argName -> [cexp| $id:(show argName) |]
)
generateCToHaskellMarshaller' hsTy cTy
| Just hsMarshalTy <- Map.lookup cTy cIntegralMap
= return ( hsMarshalTy
, cTy
, \val cont -> [| $cont (fromIntegral $val) |]
, \argName -> [cexp| $id:(show argName) |]
)
| Just hsMarshalTy <- Map.lookup cTy cFloatingMap
= return ( hsMarshalTy
, cTy
, \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 * |]
, \val cont -> [| do { str <- C.peekCString $val; C.free $val; $cont str } |]
, \argName ->
let arg = show argName
in
[cexp|
( $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 |]
= return ( [t| C.StablePtr $(return hsTy) |]
, cTy
, \val cont -> [| do { C.deRefStablePtr $val >>= $cont } |]
, \argName -> [cexp| $id:(show argName) |]
)
| cTy == [cty| void |]
= return ( [t| () |]
, [cty| void |]
, \val cont -> [| $cont $val |]
, \argName -> [cexp| $id:(show argName) |]
)
| otherwise
= 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| typename NSInteger |], [t| Int |])
, ([cty| typename NSUInteger |], [t| Word |])
]
cFloatingMap = Map.fromList
[ ([cty| float |] , [t| C.CFloat |])
, ([cty| double |], [t| C.CDouble |])
]