[hoc-cvs] hoc/InterfaceGenerator CTypeToHaskell.hs,1.6,1.7 ExportModule.hs,1.7,1.8 Main.hs,1.6,1.7 Parser.hs,1.2,1.3 PrepareDeclarations.hs,1.12,1.13 SyntaxTree.hs,1.2,1.3

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

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

Modified Files:
	CTypeToHaskell.hs ExportModule.hs Main.hs Parser.hs 
	PrepareDeclarations.hs SyntaxTree.hs 
Log Message:
A monster commit, brought to you by the Greater Toronto Airport Authority
and Czech Airlines.

HOC now supports:

* Marshalling of exceptions
    NSExceptions get marshalled into Haskell exceptions that can be caught
    using Foundation.NSException.catchNS.
    Haskell exceptions get wrapped in a (private) subclass of NSException
    and marshalled back if they re-enter Haskell land.

* importing of extern constants
    $(declareExternConst "NSDeviceRGBColorSpace" [t| NSString () |])

* importing of global functions (e.g. NSRectFill) using HOC marshalling:
    $(declareExternFun "NSRectFill" [t| NSRect -> IO () |])

* ifgen generates constant & function declarations automatically from
  Foundation and AppKit headers.



Index: PrepareDeclarations.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/InterfaceGenerator/PrepareDeclarations.hs,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -d -r1.12 -r1.13
--- PrepareDeclarations.hs	29 Jul 2005 03:39:44 -0000	1.12
+++ PrepareDeclarations.hs	27 Sep 2005 11:55:22 -0000	1.13
@@ -31,6 +31,8 @@
         pdAllInstanceSels :: [(ClassInfo, [(MangledSelector, SelectorLocation)])],
         pdAllClassSels :: [(ClassInfo, [(MangledSelector, SelectorLocation)])],
         pdEnumTypeDefinitions :: FiniteMap ModuleName [EnumType],
+        pdExternVarDeclarations :: FiniteMap ModuleName [(HType, String, String)],
+        pdExternFunDeclarations :: FiniteMap ModuleName [MangledSelector],
         pdTypeEnvironment :: TypeEnvironment
     }
 
@@ -259,10 +261,33 @@
     
     let allInstanceSels :: [ (ClassInfo, [(MangledSelector, SelectorLocation)]) ]
         allInstanceSels = [ (ci, mangleSelectors False (ciName ci) (ciNewInstanceMethods ci))
-                       | ci <- map snd cleanClassInfos ]
+                          | ci <- map snd cleanClassInfos ]
         allClassSels :: [ (ClassInfo, [(MangledSelector, SelectorLocation)]) ]
-        allClassSels =    [ (ci, mangleSelectors True (ciName ci) (ciNewClassMethods ci))
-                       | ci <- map snd cleanClassInfos ]
+        allClassSels =  [ (ci, mangleSelectors True (ciName ci) (ciNewClassMethods ci))
+                        | ci <- map snd cleanClassInfos ]
+    
+        externVarDeclarations = extractDecls varDecl
+            where varDecl (ExternVar t n)
+                    = do
+                        ht <- getVariableType typeEnv t
+                        return (ht, n, nameToLowercase n)
+                    
+                  varDecl _ = Nothing
+                  
+        externFunDeclarations = extractDecls funDecl
+            where funDecl (ExternFun sel)
+                    = do
+                        typ <- getSelectorType PlainSelector typeEnv sel
+                        return $ MangledSelector {
+                                msSel = sel,
+                                msMangled = nameToLowercase (selName sel),
+                                msType = typ
+                            }
+                  funDecl _ = Nothing
+                  
+        extractDecls f = listToFM $
+                         map (\(HeaderInfo mod _ decls) -> (mod, mapMaybe f decls)) $ 
+                         modules
     
         mangleSelectors factory clsName sels =
             mapMaybe (\(sel, location) -> do {- Maybe -}
@@ -305,5 +330,7 @@
                  pdAllInstanceSels = allInstanceSels,
                  pdAllClassSels = allClassSels,
                  pdEnumTypeDefinitions = enumDefinitions,
+                 pdExternVarDeclarations = externVarDeclarations,
+                 pdExternFunDeclarations = externFunDeclarations,
                  pdTypeEnvironment = typeEnv
              }

Index: Parser.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/InterfaceGenerator/Parser.hs,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -d -r1.2 -r1.3
--- Parser.hs	31 Mar 2005 20:48:18 -0000	1.2
+++ Parser.hs	27 Sep 2005 11:55:22 -0000	1.3
@@ -41,6 +41,7 @@
     <|> interface_decl
     <|> empty_decl
     <|> (fmap Just type_declaration)
+    <|> extern_decl
 
 empty_decl = semi objc >> return Nothing
 
@@ -244,6 +245,26 @@
 
 type_declaration = typedef <|> ctypeDecl
 
+extern_decl =
+    extern_keyword >> ctype >>= \t -> identifier objc >>= \n ->
+        do 
+            args <- parens objc (commaSep objc argument)
+            semi objc
+            return $ Just $ ExternFun (Selector n t args False)
+    <|> do
+            semi objc
+            return $ Just $ ExternVar t n
+    where
+        argument = do t <- ctype
+                      optional (identifier objc)
+                      return t
+                   
+        
+extern_keyword =
+        reserved objc "extern"
+    <|> reserved objc "FOUNDATION_EXPORT" -- N.B. "Export" vs. "Extern".
+    <|> reserved objc "APPKIT_EXTERN"
+
 skipParens = parens objc (skipMany (
     (satisfy (\x -> x /= '(' && x /= ')') >> return ())
     <|> skipParens

Index: Main.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/InterfaceGenerator/Main.hs,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -d -r1.6 -r1.7
--- Main.hs	31 Mar 2005 15:30:19 -0000	1.6
+++ Main.hs	27 Sep 2005 11:55:22 -0000	1.7
@@ -6,7 +6,6 @@
 import qualified Data.HashTable as HashTable
 import Data.List(isPrefixOf,isSuffixOf,partition)
 import Data.Maybe(fromMaybe,mapMaybe,isJust,isNothing,catMaybes,maybeToList)
-import Data.Set hiding (map, filter, null, partition, empty)
 import Control.Monad(unless)
 
 import System.Info(os)
@@ -84,7 +83,14 @@
             return $ map fst $ order $ zip mods deps
             
     modules <- fmap concat $ mapM (orderModules2 . headerNames) [foundationModules, appKitModules]
-            
+    
+    {- Debug Output:
+    print $ concat [ [ d | d@(ExternVar _ _) <- ds ]
+                   | HeaderInfo _ _ ds <- foundationModules ++ appKitModules ]
+    print $ concat [ [ d | d@(ExternFun _)   <- ds ]
+                   | HeaderInfo _ _ ds <- foundationModules ++ appKitModules ]
+    -}
+    
     selsDefinedWhere <- HashTable.new (==) (\sel -> HashTable.hashString (selName sel))
     
     allSelNames <- HashTable.new (==) HashTable.hashString

Index: ExportModule.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/InterfaceGenerator/ExportModule.hs,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -d -r1.7 -r1.8
--- ExportModule.hs	29 Jul 2005 03:39:44 -0000	1.7
+++ ExportModule.hs	27 Sep 2005 11:55:22 -0000	1.8
@@ -18,7 +18,7 @@
 import qualified Data.HashTable as HashTable
 import Data.List(nub, partition, isPrefixOf)
 import Data.Maybe(fromMaybe, catMaybes, mapMaybe, maybeToList, isNothing)
-import Data.FiniteMap(lookupFM)
+import Data.FiniteMap(lookupFM, lookupWithDefaultFM)
 import Text.PrettyPrint.HughesPJ
 
 getModuleDependencies :: PreparedDeclarations -> ModuleName -> IO [ModuleName]
@@ -54,6 +54,8 @@
                  pdAllInstanceSels = allInstanceSels,
                  pdAllClassSels = allClassSels,
                  pdEnumTypeDefinitions = allEnumDefinitions,
+                 pdExternVarDeclarations = allVarDeclarations,
+                 pdExternFunDeclarations = allFunDeclarations,
                  pdTypeEnvironment = typeEnv
              })
              selsDefinedWhere
@@ -184,8 +186,14 @@
         protoAdoptions = concat [ [ (proto ++ "Protocol", ciName ci)
                                   | proto <- setToList $ ciNewProtocols ci]
                                 | ci <- definedClassInfos, not (ciProtocol ci) ]
+                                
+        varDeclarations = lookupWithDefaultFM allVarDeclarations [] moduleName
+        funDeclarations = lookupWithDefaultFM allFunDeclarations [] moduleName
             
-    let mentionedTypeNames = nub $ concatMap (mentionedTypes . msType) selDefinitions
+    let mentionedTypeNames = nub $
+            concatMap (mentionedTypes.msType) (selDefinitions ++ funDeclarations)
+            ++ concatMap (\(t,_,_) -> varMentionedTypes t) varDeclarations
+                                
             
             -- ### we discard the information about where to import it from
             --     and then recover it later - not nice
@@ -259,6 +267,8 @@
                                  : "module HOC"
                                  : exportedSels ++ exportedProtos
                                  ++ map ("module "++) superClassModules
+                                 ++ map (\(_,_,hn) -> hn) varDeclarations
+                                 ++ map msMangled funDeclarations
                                  ++ additionalExports
                                  ))
                     <+> text "where",
@@ -294,10 +304,14 @@
             ++ map pprProtocolDecl protocolsToDeclare
             ++ [text "-- protocol adoptions"]
             ++ map pprProtoAdoption protoAdoptions
+            ++ [text "-- extern constants"]
+            ++ map pprVarDecl varDeclarations
+            ++ [text "-- extern functions"]
+            ++ map pprFunDecl funDeclarations
             ++ (map text $ additionalCodeBelow)
     
 
-        
+         
     if anythingGoingOn
         then do
             createDirectoryIfNecessary forwardDirName
@@ -316,11 +330,11 @@
                           
 idsForClass :: String -> [String]
 idsForClass name = [name, "_" ++ name, name ++ "Class", "super_" ++ name
-						-- we also need to export the phantom type 
-						-- and a data constructor(!) for it, in order to
-						-- work around GHC bug #1244882.
-						, name ++ "_(..)"
-					]
+                        -- we also need to export the phantom type 
+                        -- and a data constructor(!) for it, in order to
+                        -- work around GHC bug #1244882.
+                        , name ++ "_(..)"
+                    ]
 
 idsForSel :: String -> [String]
 idsForSel name = [name, "Has_" ++ name, "info_" ++ name, "ImpType_" ++ name]
@@ -367,3 +381,15 @@
 pprProtoAdoption :: (String, String) -> Doc
 pprProtoAdoption (protoName, className) =
     text "instance" <+> text protoName <+> parens (text className <+> text "a")
+
+pprVarDecl :: (HType, String, String) -> Doc
+pprVarDecl (t, name, _) = text "$" <> parens (text "declareExternConst"
+        <+> doubleQuotes (text name)
+        <+> text "[t|" <+> pprVariableType t <+> text "|]"
+    )
+
+pprFunDecl :: MangledSelector -> Doc
+pprFunDecl ms = text "$" <> parens (text "declareExternFun"
+        <+> doubleQuotes (text $ msName ms)
+        <+> text "[t|" <+> pprSelectorType (msType ms) <+> text "|]"
+    )

Index: SyntaxTree.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/InterfaceGenerator/SyntaxTree.hs,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -d -r1.2 -r1.3
--- SyntaxTree.hs	25 Feb 2004 15:11:21 -0000	1.2
+++ SyntaxTree.hs	27 Sep 2005 11:55:22 -0000	1.3
@@ -6,6 +6,8 @@
     |   SelectorList SelectorListHeader [SelectorListItem]
     |   Typedef CType String
     |   CTypeDecl CType
+    |   ExternVar CType String
+    |   ExternFun Selector
     deriving (Show,Eq,Ord)
 
 data SelectorListHeader = 

Index: CTypeToHaskell.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/InterfaceGenerator/CTypeToHaskell.hs,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -d -r1.6 -r1.7
--- CTypeToHaskell.hs	29 Jul 2005 03:39:44 -0000	1.6
+++ CTypeToHaskell.hs	27 Sep 2005 11:55:22 -0000	1.7
@@ -8,7 +8,11 @@
                       HSelectorType,
                       SelectorKind(..),
                       getSelectorType,
-                      mentionedTypes) where
+                      getVariableType,
+                      pprVariableType,
+                      HType(..),
+                      mentionedTypes,
+                      varMentionedTypes) where
 
 import SyntaxTree
 import Headers(ModuleName)
@@ -208,3 +212,12 @@
 
 mentionedTypes (HSelectorType tyvars context mentioned types) = mentioned
 
+
+getVariableType :: TypeEnvironment -> CType -> Maybe HType
+pprVariableType :: HType -> Doc
+
+getVariableType env t = cTypeToHaskell env True (error "### getVariableType") t
+
+pprVariableType (HType _ _ tt) = pprHTypeTerm False tt
+
+varMentionedTypes (HType _ mentioned _) = mentioned