Convert ObjCArgument class to use a type family

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,19 +97,19 @@ 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)
 
 -- 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)

hoc/HOC/HOC/CStruct.hs

@@ -14,36 +14,36 @@ 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)
     p <- get
     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
     rawThing <- lift $ peek (castPtr p)
     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 |]) [],

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 ->

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)

hoc/HOC/HOC/MessageTarget.hs

@@ -1,17 +1,19 @@
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
 module HOC.MessageTarget where
 
+import Control.Monad
 import HOC.CBits
 import HOC.Arguments
 import HOC.ID
 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
+

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

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 ->

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")

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

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 ->

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 ()