[hoc-cvs] hoc/HOC/HOC DeclareSelector.hs,1.9,1.10 ExportClass.hs,1.7,1.8 SelectorMarshaller.hs,1.8,1.9

[Wolfgang T. <wth...@us...>]

Update of /cvsroot/hoc/hoc/HOC/HOC
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv9246/HOC/HOC

Modified Files:
	DeclareSelector.hs ExportClass.hs SelectorMarshaller.hs 
Log Message:
Further code size reductions:
remove nArgs and isUnit from the SelectorInfo structure, we can calculate
them from the (reified) type of the selector when we need them in exportClass.
Additionally, wrap the SelectorInfo constructor in a function that also takes
care of calling getSelectorForName.


Index: SelectorMarshaller.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/HOC/HOC/SelectorMarshaller.hs,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -d -r1.8 -r1.9
--- SelectorMarshaller.hs	25 Jul 2005 03:59:25 -0000	1.8
+++ SelectorMarshaller.hs	26 Jul 2005 03:11:43 -0000	1.9
@@ -1,5 +1,6 @@
 module HOC.SelectorMarshaller(
         SelectorInfo(..),
+        mkSelectorInfo,
         makeMarshaller,
         makeMarshallers,
         marshallerName
@@ -22,12 +23,13 @@
 data SelectorInfo = SelectorInfo {
         selectorInfoObjCName :: String,
         selectorInfoHaskellName :: String,
-        selectorInfoCif :: FFICif,
-        selectorInfoSel :: SEL,
-        selectorInfoNArgs :: Int,
-        selectorInfoIsUnit :: Bool
+        selectorInfoCif :: !FFICif,
+        selectorInfoSel :: !SEL
     }
 
+mkSelectorInfo objCName hsName cif
+	= SelectorInfo objCName hsName cif (getSelectorForName objCName)
+
 makeMarshaller maybeInfoName haskellName nArgs isUnit isPure isRetained =
             funD haskellName [
                 clause (map varP $ infoArgument ++ map mkName arguments

Index: DeclareSelector.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/HOC/HOC/DeclareSelector.hs,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -d -r1.9 -r1.10
--- DeclareSelector.hs	26 Jul 2005 01:29:58 -0000	1.9
+++ DeclareSelector.hs	26 Jul 2005 03:11:43 -0000	1.10
@@ -164,7 +164,7 @@
                     in valD (varP $ mkName $ infoName) (normalB
                         [|
                         	let n = $(stringE name)
-                        	in SelectorInfo n
+                        	in mkSelectorInfo n
                                                 $(if haskellName == name
                                                         then [|n|]
                                                         else stringE haskellName)
@@ -172,10 +172,6 @@
                                                         "HOC.DeclareSelector"
                                                         cannedCIFTypeNames
                                                         (return $ simplifyType doctoredTypeSig))
-                                                --(getCifForSelector $(e))
-                                                (getSelectorForName n)
-                                                nArgs
-                                                isUnit
                         |]) [],
                     
                 -- type $(imptypeName) target inst = arg1 -> arg2 -> target -> IO result

Index: ExportClass.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/HOC/HOC/ExportClass.hs,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -d -r1.7 -r1.8
--- ExportClass.hs	31 Mar 2005 20:44:08 -0000	1.7
+++ ExportClass.hs	26 Jul 2005 03:11:43 -0000	1.8
@@ -157,14 +157,29 @@
             map (noBindS . exportMethod isClassMethod objCMethodList)
                 (zip methods [firstIdx..])
                 
-        exportMethod isClassMethod objCMethodList (ImplementedMethod selectorInfo methodDefinition,num) =
+        exportMethod isClassMethod objCMethodList
+                     (ImplementedMethod selectorInfo methodDefinition,num)
+            = do
+                VarI _ t _ _ <- reify $ mkName selName
+                let arrowsToList (AppT (AppT ArrowT a) b)
+                        = a : arrowsToList b
+                    arrowsToList (AppT (ConT c) b)
+                        | c == ''IO
+                        = [b]
+                    arrowsToList (ForallT _ _ a)
+                        = arrowsToList a
+                    ts = arrowsToList t
+                
+                    nArgs = length ts - 2  -- subtract target and result
+                    isUnit = last ts == ConT ''()
+                
                 exportMethod' isClassMethod objCMethodList num methodBody
                               nArgs isUnit impTypeName selExpr cifExpr
             where
                 methodBody = varE $ mkName methodDefinition
                 selName = selectorInfoHaskellName selectorInfo
-                nArgs = selectorInfoNArgs selectorInfo
-                isUnit = selectorInfoIsUnit selectorInfo
+                -- nArgs = selectorInfoNArgs selectorInfo
+                -- isUnit = selectorInfoIsUnit selectorInfo
                 
                 impTypeName = mkName $ "ImpType_" ++ selName
                 selExpr = [| selectorInfoSel $(varE $ mkName $ "info_" ++ selName) |]