diff --git a/hoc/HOC/HOC/Arguments.hs b/hoc/HOC/HOC/Arguments.hs index 1ee6b6d..59bec5b 100644 --- a/hoc/HOC/HOC/Arguments.hs +++ b/hoc/HOC/HOC/Arguments.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE TemplateHaskell, EmptyDataDecls, - MultiParamTypeClasses, FunctionalDependencies, - UndecidableInstances, ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell, EmptyDataDecls, TypeFamilies, + FlexibleContexts, ScopedTypeVariables #-} module HOC.Arguments where import HOC.FFICallInterface @@ -17,11 +16,14 @@ import HOC.TH -- importArgument is the FFIType used when importing this type -- objCTypeString is the type string that should be used to identify this type -- to the objective-c runtime. -class (Storable b, FFITypeable b) => ObjCArgument a b | a -> b where - withExportedArgument :: a -> (b -> IO c) -> IO c - exportArgument :: a -> IO b - exportArgumentRetained :: a -> IO b - importArgument :: b -> IO a +class (Storable (ForeignArg a), FFITypeable (ForeignArg a)) => ObjCArgument a where + type ForeignArg a + type ForeignArg a = a + + withExportedArgument :: a -> (ForeignArg a -> IO c) -> IO c + exportArgument :: a -> IO (ForeignArg a) + exportArgumentRetained :: a -> IO (ForeignArg a) + importArgument :: ForeignArg a -> IO a objCTypeString :: a -> String @@ -40,7 +42,7 @@ class (Storable b, FFITypeable b) => ObjCArgument a b | a -> b where -- like withArray, only tanks the ObjCArgument a b, and uses the ObjCArgument -- to translate a to b before constructing the array in the IO monad. -- b is typable to Ptr b. -withExportedArray :: ObjCArgument a b => [a] -> (Ptr b -> IO c) -> IO c +withExportedArray :: ObjCArgument a => [a] -> (Ptr (ForeignArg a) -> IO c) -> IO c withExportedArray l a = withExportedList l $ \l' -> withArray l' a where withExportedList [] a = a [] @@ -61,8 +63,7 @@ declareStorableObjCArgument ty str = -} declareStorableObjCArgument ty str = do - argInst <- instanceD (cxt []) (conT ''ObjCArgument - `appT` ty `appT` ty) + argInst <- instanceD (cxt []) (conT ''ObjCArgument `appT` ty) `whereQ` [d| {- withExportedArgument = flip ($) -} exportArgument x = return x @@ -77,7 +78,8 @@ instance Storable EvilDummyForUnit where sizeOf = undefined ; alignment = undefined ; peek = undefined ; poke = undefined instance FFITypeable EvilDummyForUnit where makeFFIType _ = makeFFIType () -instance ObjCArgument () EvilDummyForUnit where +instance ObjCArgument () where + type ForeignArg () = EvilDummyForUnit exportArgument = undefined importArgument = undefined objCTypeString _ = "v" @@ -95,9 +97,9 @@ class ObjCIMPType a where -- This defines a ObjCArgument as an objective-c method implementation. This -- is so that constant expressions can be used as implementations. -instance ObjCArgument a b => ObjCIMPType (IO a) where +instance ObjCArgument a => ObjCIMPType (IO a) where objCImpGetArgsFFI _ = return [] - objCImpGetRetFFI _ = makeFFIType (undefined :: b) + objCImpGetRetFFI _ = makeFFIType (undefined :: ForeignArg a) objCImpGetArgsString _ = [] objCImpGetRetString _ = objCTypeString (undefined :: a) @@ -105,9 +107,9 @@ instance ObjCArgument a b => ObjCIMPType (IO a) where -- of course, a function, with the right types, is also an implementation type. -- between this and the constant expression above, this will recursivly define -- rank-n functions as ObjcIMPTypes (neat eh?) -instance (ObjCArgument a c, ObjCIMPType b) => ObjCIMPType (a -> b) where +instance (ObjCArgument a, ObjCIMPType b) => ObjCIMPType (a -> b) where objCImpGetArgsFFI _ = do - arg <- makeFFIType (undefined :: c) + arg <- makeFFIType (undefined :: ForeignArg a) rest <- objCImpGetArgsFFI (undefined :: b) return (arg : rest) objCImpGetRetFFI _ = objCImpGetRetFFI (undefined :: b) diff --git a/hoc/HOC/HOC/CStruct.hs b/hoc/HOC/HOC/CStruct.hs index 6e8f173..95ddc40 100644 --- a/hoc/HOC/HOC/CStruct.hs +++ b/hoc/HOC/HOC/CStruct.hs @@ -14,20 +14,20 @@ declareCStruct :: String -> [TypeQ] -> Q [Dec] declareCStructWithTag :: String -> Maybe String -> [TypeQ] -> Q [Dec] -mkRawThing :: ObjCArgument a b => a -> b +mkRawThing :: ObjCArgument a => a -> ForeignArg a mkRawThing _ = undefined -sizeMember :: ObjCArgument a b => a -> State Int () +sizeMember :: ObjCArgument a => a -> State Int () sizeMember thing = modify (\offset -> align offset (alignment rawThing) + sizeOf rawThing) where align x a = (x + (a-1)) .&. complement (a-1) rawThing = mkRawThing thing -alignMember :: ObjCArgument a b => a -> Int +alignMember :: ObjCArgument a => a -> Int alignMember = alignment . mkRawThing -pokeMember :: ObjCArgument a b => a -> StateT (Ptr c) IO () +pokeMember :: ObjCArgument a => a -> StateT (Ptr c) IO () pokeMember thing = do rawThing <- lift $ exportArgument thing modify (`alignPtr` alignment rawThing) @@ -35,7 +35,7 @@ pokeMember thing = do lift $ poke (castPtr p) rawThing modify (`plusPtr` sizeOf rawThing) -peekMember :: ObjCArgument a b => StateT (Ptr c) IO a +peekMember :: ObjCArgument a => StateT (Ptr c) IO a peekMember = (mfix $ \result -> do modify (`alignPtr` alignment result) p <- get @@ -43,7 +43,7 @@ peekMember = (mfix $ \result -> do modify (`plusPtr` sizeOf rawThing) return rawThing) >>= \rawThing -> lift (importArgument rawThing) -ffiMember :: ObjCArgument a b => a -> StateT [FFIType] IO () +ffiMember :: ObjCArgument a => a -> StateT [FFIType] IO () ffiMember thing = do t <- lift $ makeFFIType (mkRawThing thing) modify (t :) @@ -115,8 +115,7 @@ declareCStructWithTag cname mbTag fieldTypes ] ] - argDecl <- instanceD (cxt []) (conT ''ObjCArgument `appT` - conT name `appT` conT name) + argDecl <- instanceD (cxt []) (conT ''ObjCArgument `appT` conT name) [ valD (varP 'exportArgument) (normalB [| return |]) [], valD (varP 'importArgument) (normalB [| return |]) [], diff --git a/hoc/HOC/HOC/ID.hs b/hoc/HOC/HOC/ID.hs index 6c9ac6f..af98a10 100644 --- a/hoc/HOC/HOC/ID.hs +++ b/hoc/HOC/HOC/ID.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DoRec, MultiParamTypeClasses, FlexibleInstances, NPlusKPatterns #-} +{-# LANGUAGE DoRec, TypeFamilies, FlexibleInstances, NPlusKPatterns #-} module HOC.ID where import HOC.Arguments @@ -67,7 +67,8 @@ replaceRetainedHaskellPart self newHSO = do freeStablePtr oldHSO setRetainedHaskellPart self newHSO -instance ObjCArgument (ID a) (Ptr ObjCObject) where +instance ObjCArgument (ID a) where + type ForeignArg (ID a) = Ptr ObjCObject -- remember that thing may be lazy and never evaluated, -- including by "action" Thus you must evaluate "thing" -- to ensure that the HSO object is properly allocated. @@ -243,10 +244,6 @@ getHaskellData_IMP super mbDat cif ret args = do getHaskellDataForID (ID (HSO _ dat)) = dat -releaseExtraReference obj - = withExportedArgument obj (\ptr -> when (ptr /= nullPtr) (releaseObject ptr)) - >> return obj - objectMapStatistics = alloca $ \pAllocated -> alloca $ \pImmortal -> diff --git a/hoc/HOC/HOC/Invocation.hs b/hoc/HOC/HOC/Invocation.hs index 4e3516d..cadde8e 100644 --- a/hoc/HOC/HOC/Invocation.hs +++ b/hoc/HOC/HOC/Invocation.hs @@ -15,7 +15,7 @@ callWithException cif fun ret args = do when (exception /= nullPtr) $ exceptionObjCToHaskell exception -withMarshalledArgument :: ObjCArgument a b => a -> (Ptr () -> IO c) -> IO c +withMarshalledArgument :: ObjCArgument a => a -> (Ptr () -> IO c) -> IO c withMarshalledArgument arg act = withExportedArgument arg (\exported -> with exported (act . castPtr)) @@ -27,7 +27,7 @@ callWithoutRetval :: FFICif -> FunPtr a callWithoutRetval cif fun args = callWithException cif fun nullPtr args -callWithRetval :: ObjCArgument b c +callWithRetval :: ObjCArgument b => FFICif -> FunPtr a -> Ptr (Ptr ()) -> IO b @@ -38,12 +38,12 @@ callWithRetval cif fun args = do >> peekRetval retptr >>= importArgument -setMarshalledRetval :: ObjCArgument a b => Bool -> Ptr () -> a -> IO () +setMarshalledRetval :: ObjCArgument a => Bool -> Ptr () -> a -> IO () setMarshalledRetval retained ptr val = (if retained then exportArgumentRetained else exportArgument) val >>= poke (castPtr ptr) -getMarshalledArgument :: ObjCArgument a b => Ptr (Ptr ()) -> Int -> IO a +getMarshalledArgument :: ObjCArgument a => Ptr (Ptr ()) -> Int -> IO a getMarshalledArgument args idx = do p <- peekElemOff args idx arg <- peek (castPtr p) diff --git a/hoc/HOC/HOC/MessageTarget.hs b/hoc/HOC/HOC/MessageTarget.hs index 6cd866a..0975876 100644 --- a/hoc/HOC/HOC/MessageTarget.hs +++ b/hoc/HOC/HOC/MessageTarget.hs @@ -1,6 +1,8 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} module HOC.MessageTarget where +import Control.Monad import HOC.CBits import HOC.Arguments import HOC.ID @@ -8,10 +10,10 @@ import HOC.MsgSend import HOC.FFICallInterface(FFICif) import Foreign.Ptr -class ObjCArgument a (Ptr ObjCObject) => MessageTarget a where +class (ObjCArgument a, ForeignArg a ~ Ptr ObjCObject) => MessageTarget a where isNil :: a -> Bool - sendMessageWithRetval :: ObjCArgument ret b + sendMessageWithRetval :: ObjCArgument ret => a -> FFICif -> Ptr (Ptr ()) @@ -43,3 +45,9 @@ failNilMessage :: MessageTarget t => t -> String -> IO () failNilMessage target selectorName | isNil target = fail $ "Message sent to nil: " ++ selectorName | otherwise = return () + +releaseExtraReference :: MessageTarget a => a -> IO a +releaseExtraReference obj + = withExportedArgument obj (\ptr -> when (ptr /= nullPtr) (releaseObject ptr)) + >> return obj + diff --git a/hoc/HOC/HOC/MsgSend.hs b/hoc/HOC/HOC/MsgSend.hs index 15a2dac..f8633ff 100644 --- a/hoc/HOC/HOC/MsgSend.hs +++ b/hoc/HOC/HOC/MsgSend.hs @@ -13,7 +13,7 @@ import HOC.Invocation import Foreign objSendMessageWithRetval - :: ObjCArgument a b + :: ObjCArgument a => FFICif -> Ptr (Ptr ()) -> IO a @@ -24,7 +24,7 @@ objSendMessageWithoutRetval -> IO () superSendMessageWithRetval - :: ObjCArgument a b + :: ObjCArgument a => FFICif -> Ptr (Ptr ()) -> IO a diff --git a/hoc/HOC/HOC/NewlyAllocated.hs b/hoc/HOC/HOC/NewlyAllocated.hs index 8c77cff..cac86fa 100644 --- a/hoc/HOC/HOC/NewlyAllocated.hs +++ b/hoc/HOC/HOC/NewlyAllocated.hs @@ -1,5 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, - ScopedTypeVariables #-} + ScopedTypeVariables, TypeFamilies #-} module HOC.NewlyAllocated where {- @@ -27,7 +27,9 @@ data NewlyAllocated a = NewlyAllocated (Ptr ObjCObject) | NewSuper (Ptr ObjCObject) (Class ()) -instance ObjCArgument (NewlyAllocated a) (Ptr ObjCObject) where +instance ObjCArgument (NewlyAllocated a) where + type ForeignArg (NewlyAllocated a) = Ptr ObjCObject + withExportedArgument (NewlyAllocated p) action = action p withExportedArgument (NewSuper p cls) action = withExportedArgument cls $ \cls -> diff --git a/hoc/HOC/HOC/SelectorMarshaller.hs b/hoc/HOC/HOC/SelectorMarshaller.hs index 6bfc43d..deecd58 100644 --- a/hoc/HOC/HOC/SelectorMarshaller.hs +++ b/hoc/HOC/HOC/SelectorMarshaller.hs @@ -114,7 +114,7 @@ makeMarshaller maybeInfoName haskellName nArgs isUnit isPure isRetained = purify e | isPure = [| unsafePerformIO $(e) |] | otherwise = e - releaseRetvalIfRetained e | isRetained = [| $(e) >>= releaseExtraReference |] + releaseRetvalIfRetained e | isRetained = [| $e >>= releaseExtraReference |] | otherwise = e checkTargetNil e = [| failNilMessage $(varE $ mkName "target") diff --git a/hoc/HOC/HOC/StdArgumentTypes.hs b/hoc/HOC/HOC/StdArgumentTypes.hs index 49c56e6..cbc1c26 100644 --- a/hoc/HOC/HOC/StdArgumentTypes.hs +++ b/hoc/HOC/HOC/StdArgumentTypes.hs @@ -1,5 +1,5 @@ {-# LANGUAGE TemplateHaskell, - MultiParamTypeClasses, UndecidableInstances, + TypeFamilies, UndecidableInstances, TypeSynonymInstances, FlexibleInstances, ScopedTypeVariables #-} module HOC.StdArgumentTypes where @@ -23,7 +23,8 @@ instance FFITypeable SEL where $(declareStorableObjCArgument [t| SEL |] ":") -instance ObjCArgument Bool CSChar where +instance ObjCArgument Bool where + type ForeignArg Bool = CSChar exportArgument False = return 0 exportArgument True = return 1 importArgument 0 = return False @@ -35,8 +36,7 @@ $(declareStorableObjCArgument [t| Int |] "l") $(declareStorableObjCArgument [t| Float |] "f") $(declareStorableObjCArgument [t| Double |] "d") -instance ObjCArgument a b => - ObjCArgument (Ptr a) (Ptr a) where +instance ObjCArgument a => ObjCArgument (Ptr a) where exportArgument a = return a importArgument a = return a objCTypeString _ @@ -69,7 +69,9 @@ $(declareStorableObjCArgument [t| CULLong |] "Q") withUTF8String str = withArray0 0 (unicodeToUtf8 str) -instance ObjCArgument a (Ptr b) => ObjCArgument (Maybe a) (Ptr b) where +instance (ObjCArgument a, ForeignArg a ~ Ptr b) => ObjCArgument (Maybe a) where + type ForeignArg (Maybe a) = ForeignArg a + withExportedArgument Nothing action = action nullPtr withExportedArgument (Just x) action = withExportedArgument x action exportArgument Nothing = return nullPtr @@ -79,7 +81,9 @@ instance ObjCArgument a (Ptr b) => ObjCArgument (Maybe a) (Ptr b) where | otherwise = fmap Just (importArgument p) objCTypeString _ = objCTypeString (undefined :: a) -instance ObjCArgument String (Ptr ObjCObject) where +instance ObjCArgument String where + type ForeignArg String = Ptr ObjCObject + withExportedArgument arg action = bracket (withUTF8String arg utf8ToNSString) releaseObject action exportArgument arg = do diff --git a/hoc/HOC/HOC/Super.hs b/hoc/HOC/HOC/Super.hs index 6d4d28f..35000e6 100644 --- a/hoc/HOC/HOC/Super.hs +++ b/hoc/HOC/HOC/Super.hs @@ -1,6 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances, FlexibleInstances, - FlexibleContexts #-} + FlexibleContexts, TypeFamilies #-} module HOC.Super( SuperClass, SuperTarget, Super(super), withExportedSuper, castSuper ) where @@ -40,7 +40,8 @@ withExportedSuper p cls action = pokeSuper sptr p cls >> action sptr instance MessageTarget a - => ObjCArgument (SuperTarget a) (Ptr ObjCObject) where + => ObjCArgument (SuperTarget a) where + type ForeignArg (SuperTarget a) = Ptr ObjCObject withExportedArgument (SuperTarget obj cls) action = withExportedArgument obj $ \p -> diff --git a/hoc/Tests/TestFFI.hs b/hoc/Tests/TestFFI.hs index e7555f3..4410cdc 100644 --- a/hoc/Tests/TestFFI.hs +++ b/hoc/Tests/TestFFI.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ForeignFunctionInterface, RankNTypes #-} +{-# LANGUAGE ForeignFunctionInterface, RankNTypes, TypeFamilies #-} module TestFFI where import HOC.FFICallInterface @@ -23,10 +23,10 @@ fficallDirectly cif fp args peekRetval ret type Invoker = forall a b c d. - (ObjCArgument a a, ObjCArgument b b) => + (ObjCArgument a, ForeignArg a ~ a, ObjCArgument b, ForeignArg b ~ b) => FFICif -> FunPtr (a -> b) -> Ptr (Ptr ()) -> IO b -testArgAndResult :: (Eq a, Num a, Eq b, Show b, Num b, ObjCArgument a a, ObjCArgument b b) +testArgAndResult :: (Eq a, Num a, Eq b, Show b, Num b, ObjCArgument a, ForeignArg a ~ a, ObjCArgument b, ForeignArg b ~ b) => Invoker -> FunPtr (a -> b) -> IO ()