Menu
▾
▴
[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
|
From: Wolfgang T. <wth...@us...> - 2005-09-27 11:55:35
|
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 |
