[hoc-cvs] hoc/HOC/HOC ExportClass.hs,1.9,1.10 TH.hs,1.2,1.3

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

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

Modified Files:
	ExportClass.hs TH.hs 
Log Message:
Use a (Template Haskell) Name rather than the selector info as a parameter
for InstanceMethod, i.e. instead of

$(exportClass ... [
        InstanceMethod info_foo
    ])

we now write

$(exportClass ... [
        InstanceMethod 'foo
    ])

Most importantly, it is no longer necessary to declare the selectors used
in exportClass in a separate file.


Index: TH.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/HOC/HOC/TH.hs,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -d -r1.2 -r1.3
--- TH.hs	29 Jul 2005 03:39:44 -0000	1.2
+++ TH.hs	20 Mar 2006 06:25:26 -0000	1.3
@@ -3,7 +3,9 @@
         mkNameG_v,
         mkNameG_tc,
         mkNameG_d,
-        whereQ
+        whereQ,
+        fromSameModuleAs_tc,
+        fromSameModuleAs_v
     ) where
 
 import Language.Haskell.TH
@@ -17,3 +19,14 @@
     decls <- declsQ
     header (map return decls)
 
+fromSameModuleAs_tc :: String -> Name -> Name
+s `fromSameModuleAs_tc` n
+    = case nameModule n of
+        Nothing -> mkName s
+        Just m -> mkNameG_tc m s
+        
+fromSameModuleAs_v :: String -> Name -> Name
+s `fromSameModuleAs_v` n
+    = case nameModule n of
+        Nothing -> mkName s
+        Just m -> mkNameG_v m s

Index: ExportClass.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/HOC/HOC/ExportClass.hs,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -d -r1.9 -r1.10
--- ExportClass.hs	27 Sep 2005 11:55:22 -0000	1.9
+++ ExportClass.hs	20 Mar 2006 06:25:26 -0000	1.10
@@ -19,8 +19,8 @@
 import HOC.Exception
 
 data ClassMember =
-        InstanceMethod SelectorInfo
-    |   ClassMethod SelectorInfo
+        InstanceMethod Name
+    |   ClassMethod Name
     |   Outlet String TypeQ
     |   InstanceVariable String TypeQ ExpQ
 
@@ -108,7 +108,7 @@
                 wrap = foldl appE (conE $ mkName instanceDataName) (map (varE.mkName) ivarNames)
                 initIVar (ivar,ty,initial) = bindS (varP $ mkName ivar) [| newMVar $(initial) |]
 
-data Method = ImplementedMethod SelectorInfo String
+data Method = ImplementedMethod Name
             | GetterMethod String
             | SetterMethod String
 
@@ -134,18 +134,16 @@
             `sigE` (conT ''IO `appT` conT (mkName $ name ++ "_IVARS"))
     
         outlets = [ name | Outlet name _ <- members ]
-        classMethods =    [ ImplementedMethod info (prefix ++ selectorInfoHaskellName info)
-                          | ClassMethod info <- members ] 
+        classMethods = [ ImplementedMethod n | ClassMethod n <- members ] 
 
-        explicitInstanceMethods = [ (info, prefix ++ selectorInfoHaskellName info)
-                                  | InstanceMethod info <- members ]         
-        instanceMethodNames = map (selectorInfoObjCName . fst) explicitInstanceMethods
+        explicitInstanceMethods = [ n | InstanceMethod n <- members ]         
+        instanceMethodNames = map nameBase explicitInstanceMethods
         instanceMethods =
-                [ ImplementedMethod i d | (i,d) <- explicitInstanceMethods ] 
+                map ImplementedMethod explicitInstanceMethods 
              ++ [ GetterMethod ivar | ivar <- outlets,
                                       not (ivar `elem` instanceMethodNames) ]
              ++ [ SetterMethod ivar | ivar <- outlets,
-                                      not (setterNameFor ivar
+                                      not (setterNameForH ivar
                                            `elem` instanceMethodNames) ]
   
         nIMethods = length instanceMethods
@@ -159,9 +157,9 @@
                 (zip methods [firstIdx..])
                 
         exportMethod isClassMethod objCMethodList
-                     (ImplementedMethod selectorInfo methodDefinition,num)
+                     (ImplementedMethod selName, num)
             = do
-                VarI _ t _ _ <- reify $ mkName selName
+                VarI _ t _ _ <- reify $ selName
                 let arrowsToList (AppT (AppT ArrowT a) b)
                         = a : arrowsToList b
                     arrowsToList (AppT (ConT c) b)
@@ -177,14 +175,17 @@
                 exportMethod' isClassMethod objCMethodList num methodBody
                               nArgs isUnit impTypeName selExpr cifExpr
             where
-                methodBody = varE $ mkName methodDefinition
-                selName = selectorInfoHaskellName selectorInfo
-                -- nArgs = selectorInfoNArgs selectorInfo
-                -- isUnit = selectorInfoIsUnit selectorInfo
+                methodBody = varE $ mkName $ prefix ++ nameBase selName
                 
-                impTypeName = mkName $ "ImpType_" ++ selName
-                selExpr = [| selectorInfoSel $(varE $ mkName $ "info_" ++ selName) |]
-                cifExpr = [| selectorInfoCif $(varE $ mkName $ "info_" ++ selName) |]
+                -- selName = selectorInfoHaskellName selectorInfo
+                
+                impTypeName = ("ImpType_" ++ nameBase selName)
+                                `fromSameModuleAs_tc` selName
+                infoName = ("info_" ++ nameBase selName)
+                            `fromSameModuleAs_v` selName
+                
+                selExpr = [| selectorInfoSel $(varE $ infoName) |]
+                cifExpr = [| selectorInfoCif $(varE $ infoName) |]
         
         exportMethod isClassMethod objCMethodList (GetterMethod ivarName, num) =
                 exportMethod' isClassMethod objCMethodList num
@@ -202,7 +203,8 @@
             where
                 setterName = setterNameFor ivarName
         
-        setterNameFor ivarName = "set" ++ toUpper (head ivarName) : tail ivarName ++ ":"
+        setterNameFor ivarName = setterNameForH ivarName ++ ":"
+        setterNameForH ivarName = "set" ++ toUpper (head ivarName) : tail ivarName
             
                 
         exportMethod' isClassMethod objCMethodList num methodBody