Menu
▾
▴
[hoc-cvs] [hoc commit] r312 - trunk/hoc/InterfaceGenerator2
|
From: <cod...@go...> - 2008-09-25 23:36:24
|
Author: wol...@gm...
Date: Thu Sep 25 16:35:43 2008
New Revision: 312
Modified:
trunk/hoc/InterfaceGenerator2/BindingScript.hs
trunk/hoc/InterfaceGenerator2/BuildEntities.hs
trunk/hoc/InterfaceGenerator2/DependenceGraphs.hs
trunk/hoc/InterfaceGenerator2/DuplicateEntities.hs
trunk/hoc/InterfaceGenerator2/Entities.hs
trunk/hoc/InterfaceGenerator2/Files.hs
trunk/hoc/InterfaceGenerator2/HackEnumNames.hs
trunk/hoc/InterfaceGenerator2/Main.hs
trunk/hoc/InterfaceGenerator2/Messages.hs
trunk/hoc/InterfaceGenerator2/Output.hs
trunk/hoc/InterfaceGenerator2/Preprocessor.hs
trunk/hoc/InterfaceGenerator2/ResolveAndZap.hs
Log:
Some general cleanup.
Modified: trunk/hoc/InterfaceGenerator2/BindingScript.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/BindingScript.hs (original)
+++ trunk/hoc/InterfaceGenerator2/BindingScript.hs Thu Sep 25 16:35:43 2008
@@ -38,7 +38,8 @@
soHiddenSelectors :: Set String,
soChangedSelectors :: Map.Map String Selector
}
-
+
+emptyBindingScript :: BindingScript
emptyBindingScript
= BindingScript {
bsHiddenFromPrelude = Set.empty,
@@ -52,7 +53,8 @@
bsAdditionalTypes = [],
bsClassSpecificOptions = Map.empty
}
-
+
+defaultNameMappings :: Map.Map String String
defaultNameMappings = Map.fromList [
("data", "data'"),
("type", "type'"),
@@ -78,8 +80,10 @@
where
top = bsTopLevelOptions bindingScript
+tokenParser :: TokenParser ()
tokenParser = makeTokenParser $ haskellStyle { identStart = letter <|>
char '_' }
+selector, qualified :: TokenParser () -> Parser String
selector tp = lexeme tp $ do
c <- letter <|> char '_'
s <- many (alphaNum <|> oneOf "_:")
@@ -163,6 +167,7 @@
eof
let wrongThings = [ () | ReplaceSelector _ <- statements ]
+ when (not $ null wrongThings) $ fail "illegal thing at top level"
return $ BindingScript {
bsHiddenFromPrelude = Set.fromList [ ident | HidePrelude ident
<- statements ],
Modified: trunk/hoc/InterfaceGenerator2/BuildEntities.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/BuildEntities.hs (original)
+++ trunk/hoc/InterfaceGenerator2/BuildEntities.hs Thu Sep 25 16:35:43 2008
@@ -43,6 +43,7 @@
makeEntities :: BindingScript -> [HeaderInfo] -> EntityPile -> EntityPile
+assertHaskellTypeName :: BS.ByteString -> BS.ByteString
assertHaskellTypeName xs
| not (BS.null xs)
&& isUpper x && BS.all (\c -> isAlphaNum c || c `elem` "_'") xs
@@ -86,7 +87,7 @@
-- Workaround: If there is both an instance method and a class
method of the
-- same name, don't use covariant.
- makeSelectorEntity factory modName clsID clsName sel
+ makeSelectorEntity factory modName _clsID clsName sel
= if hidden
then return Nothing
else do
@@ -132,11 +133,11 @@
= makeSelectorEntity False modName clsID clsName sel
makeEntitiesForSelectorListItem modName clsID clsName (ClassMethod
sel)
= makeSelectorEntity True modName clsID clsName sel
- makeEntitiesForSelectorListItem modName clsID clsName (LocalDecl
decl)
+ makeEntitiesForSelectorListItem modName _clsID _clsName (LocalDecl
decl)
= makeEntity modName decl >> return Nothing
- makeEntitiesForSelectorListItem modName clsID clsName PropertyDecl
+ makeEntitiesForSelectorListItem _modName _clsID _clsName
PropertyDecl
= return Nothing
- makeEntitiesForSelectorListItem modName clsID clsName (Required _)
+ makeEntitiesForSelectorListItem _modName _clsID _clsName (Required
_)
= return Nothing
makeSelectorEntities modName clsID clsName items
@@ -203,11 +204,11 @@
eModule = LocalModule modName
}
) >> return ()
- makeEntity modName (Typedef (CTStruct n2 fields) name)
+ makeEntity _modName (Typedef (CTStruct _n2 _fields) _name)
= return ()
- makeEntity modName (Typedef (CTUnion n2 fields) name)
+ makeEntity _modName (Typedef (CTUnion _n2 _fields) _name)
= return ()
- makeEntity modName (Typedef (CTEnum n2 vals) name)
+ makeEntity modName (Typedef (CTEnum _n2 vals) name)
| notHidden name
= makeEnum name modName vals
-- makeAnonymousEnum modName vals -- ### HACK for 10.5:
ignore enum names
@@ -250,7 +251,7 @@
return ()
where name = selName sel
- makeEntity modName _ = return ()
+ makeEntity _modName _ = return ()
convertEnumEntities :: [(String, EnumValue)]
-> (Bool, [(BS.ByteString, Integer)])
Modified: trunk/hoc/InterfaceGenerator2/DependenceGraphs.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/DependenceGraphs.hs (original)
+++ trunk/hoc/InterfaceGenerator2/DependenceGraphs.hs Thu Sep 25 16:35:43
2008
@@ -1,9 +1,10 @@
module DependenceGraphs(
- entitiesRequiredByEntity,
RGr,
- makeEntityGraph,
+ -- used by DuplicateEntities:
+ makeModuleDAG,
+ -- used by Output & Main:
+ entitiesRequiredByEntity,
makeModuleGraph,
- makeModuleDAG,
topsortEntities,
minimizeSourceImports,
isSourceImport
@@ -25,28 +26,6 @@
= mentionedEntityIDs e
type RGr a b = (Gr a b, Map.Map a Node)
-
-makeEntityGraph :: EntityPile -> RGr EntityID Bool
-makeEntityGraph entityPile
- = (gr, entityToNode)
- where
- entities = localEntities entityPile
- entityToNode = Map.fromList $ zip (Map.keys entities) [1..]
- gr = mkGraph (zip [1..] (Map.keys entities)) $
- do {- list -}
- (fromEntityID, e) <- Map.toList entities
- let from = entityToNode Map.! fromEntityID
- weak = case eInfo e of
- ProtocolEntity _ _ -> True
- _ -> False
- toEntityID <- entitiesRequiredByEntity e
-
- case toEntityID of
- LocalEntity _ ->
- return (from, entityToNode Map.! toEntityID,
- weak)
- FrameworkEntity _ _ ->
- []
makeModuleGraph :: EntityPile -> RGr Module Bool
makeModuleGraph entityPile
Modified: trunk/hoc/InterfaceGenerator2/DuplicateEntities.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/DuplicateEntities.hs (original)
+++ trunk/hoc/InterfaceGenerator2/DuplicateEntities.hs Thu Sep 25 16:35:43
2008
@@ -61,6 +61,7 @@
redirect eid = fromMaybe eid $ Map.lookup eid remappings
+combineDulicateEntities :: EntityPile -> EntityPile
combineDulicateEntities entityPile
= resolve entityPile
where
Modified: trunk/hoc/InterfaceGenerator2/Entities.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Entities.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Entities.hs Thu Sep 25 16:35:43 2008
@@ -95,7 +95,7 @@
addImportedEntities :: ModuleName -> EntityMap
-> EntityPile -> EntityPile
-addImportedEntities mod entities pile
+addImportedEntities _mod entities pile
= pile { epFrameworkEntities = entities `Map.union`
epFrameworkEntities pile }
newEntity :: MonadState EntityPile m => Entity -> m EntityID
@@ -147,33 +147,15 @@
transformLocalEntities :: (EntityMap -> EntityMap)
-> EntityPile -> EntityPile
-{-transformLocalEntities f (EntityPile entities nextID)
- = EntityPile (fwEntities `Map.union` localEntities') nextID
- where
- (fwEntities, localEntities)
- = Map.partitionWithKey isFramework entities
- localEntities' = f localEntities
-
- isFramework (FrameworkEntity _ _) _ = True
- isFramework _ _ = False-}
transformLocalEntities f pile
= pile { epEntities = f (epEntities pile) }
--- transformLocalEntities f = f
-localEntities :: EntityPile -> EntityMap
-{-
-localEntities = Map.filterWithKey notFramework . epEntities
- where
- notFramework (FrameworkEntity _ _) _ = False
- notFramework _ _ = True
--}
+localEntities, frameworkEntities :: EntityPile -> EntityMap
localEntities = epEntities
frameworkEntities = epFrameworkEntities
replaceLocalEntities :: EntityMap -> EntityPile -> EntityPile
replaceLocalEntities locals = transformLocalEntities (const locals)
--- localEntityPile :: EntityPile -> EntityPile
--- localEntityPile pile = EntityPile (localEntities pile) (epNextID pile)
-
+reportProgressForPile :: ProgressReporter -> EntityPile -> EntityPile
reportProgressForPile pr = transformLocalEntities (reportProgressForMap pr)
Modified: trunk/hoc/InterfaceGenerator2/Files.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Files.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Files.hs Thu Sep 25 16:35:43 2008
@@ -1,10 +1,6 @@
module Files(
- additionalCodePath,
- outputPath,
writeFileIfChanged,
- readFileOrEmpty,
createDirectoryIfNecessary,
- createOutputDirectories,
createParentDirectoriesIfNecessary
) where
@@ -14,11 +10,7 @@
doesFileExist,
createDirectory)
-outputDir = "ifgen-output"
-outputPath f = outputDir ++ "/" ++ f
-
-additionalCodePath f = "AdditionalCode/" ++ f
-
+writeFileIfChanged :: FilePath -> String -> IO ()
writeFileIfChanged fn text = do
exists <- doesFileExist fn
if exists
@@ -29,10 +21,12 @@
writeFile fn text
else writeFile fn text
+createDirectoryIfNecessary :: FilePath -> IO ()
createDirectoryIfNecessary dir = do
exists <- doesDirectoryExist dir
unless exists $ createDirectory dir
+createParentDirectoriesIfNecessary :: FilePath -> IO ()
createParentDirectoriesIfNecessary f
= work (dropWhile (/= '/') $ reverse f)
where
@@ -41,16 +35,3 @@
work fr = do
work $ dropWhile (/='/') fr
createDirectoryIfNecessary (reverse fr)
-
-createOutputDirectories frameworks = do
- createDirectoryIfNecessary outputDir
- mapM_ createDirectoryIfNecessary (map outputPath frameworks)
-
-readFileOrEmpty fn = do
- exists <- doesFileExist fn
- if exists
- then do
- contents <- readFile fn
- return $ Just contents
- else do
- return Nothing
Modified: trunk/hoc/InterfaceGenerator2/HackEnumNames.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/HackEnumNames.hs (original)
+++ trunk/hoc/InterfaceGenerator2/HackEnumNames.hs Thu Sep 25 16:35:43 2008
@@ -4,6 +4,8 @@
import SyntaxTree
import Headers
+hackEnumNames :: HeaderInfo -> HeaderInfo
+
hackEnumNames (HeaderInfo name imports decls)
= HeaderInfo name imports (hackEnums1 Just id decls)
where
Modified: trunk/hoc/InterfaceGenerator2/Main.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Main.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Main.hs Thu Sep 25 16:35:43 2008
@@ -1,27 +1,23 @@
{-# LANGUAGE CPP #-}
module Main where
-import Headers
+import qualified Data.ByteString.Char8 as BS
import qualified Data.Map as Map
import qualified Data.Set as Set
-import Control.Monad.Writer
-import BindingScript
-import Data.Char
-import Data.Maybe
--- import Data.Generics
+import Data.Maybe ( fromMaybe )
+import Control.Monad ( when )
import System.IO
+import System.Environment ( getArgs )
+import System.Console.GetOpt
+import Control.Exception ( finally )
import Messages
import Entities
--- import Traversals
+import BindingScript
import Files
import Progress
-import qualified Data.ByteString.Char8 as BS
-import System.Environment
-import System.Console.GetOpt
-import Control.Exception
#ifdef BINARY_INTERFACES
import Data.Binary ( encodeFile, decode )
@@ -29,26 +25,23 @@
import qualified Data.ByteString.Lazy as LBS
#endif
-import HackEnumNames
-import BuildEntities
+
+import Headers -- (on disk) -> [HeaderInfo]
+import HackEnumNames -- HeaderInfo -> HeaderInfo
+import BuildEntities -- [HeaderInfo] -> EntityPile
+
+ -- EntityPile -> EntityPile passes
import ResolveAndZap
-import DependenceGraphs
import ShuffleInstances
import DuplicateEntities
-import Output
-
-textInterfaces = False -- Overall 3 times faster with binary
-
-{-deepEvaluatePile = mapM_ deepEvaluateEntity . Map.elems . localEntities
-evalWithProgress str pile
- = runShowingProgress str $
- \progress -> deepEvaluatePile $ reportProgressForPile progress $
pile
--}
+import DependenceGraphs
+import Output
instance Monitorable EntityPile where
monitor pr = transformLocalEntities (monitor pr)
+writeFrameworkModules :: ProgressReporter -> EntityPile -> FilePath -> IO
()
writeFrameworkModules progress entityPile path
= do
let byModule = makeEntityPileLocalMultiIndex eModule $
@@ -62,8 +55,8 @@
modGraph = minimizeSourceImports $ makeModuleGraph entityPile
- flip mapM_ (zip [0..] $ Map.toList byModule) $
- \(index, (mod, entityID)) -> do
+ flip mapM_ (Map.toList byModule) $
+ \(mod, entityID) -> do
case mod of
FrameworkModule _ _ -> return ()
LocalModule modName -> do
@@ -76,6 +69,7 @@
show $ pprHsModule entityPile modGraph modName
entities
reportProgress progress nModules
+readFileWithProgress :: ProgressReporter -> FilePath -> IO String
readFileWithProgress progress fn
= do
bs <- BS.readFile fn
@@ -83,6 +77,7 @@
return $ monitorList progress n $ BS.unpack bs
#ifdef BINARY_INTERFACES
+decodeFileWithProgress :: ProgressReporter -> FilePath -> IO EntityMap
decodeFileWithProgress progress fn
= do
bs <- fmap LBS.toChunks $ LBS.readFile fn
@@ -90,6 +85,7 @@
return $ decode $ LBS.fromChunks $ monitorList progress n $ bs
#endif
+readInterfaceFileWithProgress :: ProgressReporter -> FilePath -> IO
EntityMap
readInterfaceFileWithProgress progress fn
#ifdef BINARY_INTERFACES
= decodeFileWithProgress progress fn
@@ -97,6 +93,7 @@
= fmap read $ readFileWithProgress progress fn
#endif
+writeInterfaceFileWithProgress :: ProgressReporter -> FilePath ->
EntityPile -> IO ()
writeInterfaceFileWithProgress progress fn entities
#ifdef BINARY_INTERFACES
= encodeFile fn $
@@ -122,6 +119,7 @@
oQuiet :: Bool
}
+processFramework :: Options -> IO ()
processFramework options -- bs frameworkName requiredFrameworks
= do
bs <- maybe (return emptyBindingScript) readBindingScript $
@@ -232,12 +230,14 @@
putStrLn $ "done."
-
+addRequiredFramework :: String -> Options -> Options
addRequiredFramework fw o
= o { oRequiredFrameworks = fw : oRequiredFrameworks o }
+addHeaderDirectory :: HeaderDirectory -> Options -> Options
addHeaderDirectory hd o
= o { oHeaderDirectories = hd : oHeaderDirectories o }
-
+
+optionDescs :: [OptDescr (Options -> Options)]
optionDescs = [
Option ['d'] ["depend"]
(ReqArg addRequiredFramework
@@ -279,6 +279,8 @@
(NoArg (\o -> o { oQuiet = True }))
"don't report progress"
]
+
+main :: IO ()
main = do
args <- getArgs
case getOpt Permute optionDescs args of
Modified: trunk/hoc/InterfaceGenerator2/Messages.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Messages.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Messages.hs Thu Sep 25 16:35:43 2008
@@ -18,9 +18,6 @@
helper (UnitBag x) xs = x : xs
helper (BagOfTwo a b) xs = helper a $ helper b xs
-nullBag EmptyBag = True
-nullBag _ = False
-
instance Monoid (Bag a) where
mempty = EmptyBag
mappend EmptyBag b = b
Modified: trunk/hoc/InterfaceGenerator2/Output.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Output.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Output.hs Thu Sep 25 16:35:43 2008
@@ -204,14 +204,14 @@
pprEntity e@(Entity { eInfo = EnumEntity complete constants })
= char '$' <> parens (
declare <+> brackets (
- hcat $ punctuate comma $ map pprAssoc constants
- )
+ hcat $ punctuate comma $ map pprAssoc constants
+ )
)
- where
+ where
declare = case eName e of
CName cname -> text "declareCEnum" <+> doubleQuotes
(textBS cname)
Anonymous -> text "declareAnonymousCEnum"
- pprAssoc (n, v)
+ pprAssoc (n, v)
= parens (doubleQuotes (textBS n) <> comma <+> integer
v)
pprEntity e@(Entity { eInfo = AdditionalCodeEntity _ _ _ txt })
Modified: trunk/hoc/InterfaceGenerator2/Preprocessor.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Preprocessor.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Preprocessor.hs Thu Sep 25 16:35:43 2008
@@ -107,10 +107,6 @@
execute filename xs = unlines $ evalState (exec xs []) macros where
exec (If e : xs) state@( (_, False) : _ )
= output "//#if" $ exec xs ((PPSIf False, False) : state)
--- exec (Elif e : xs) state@( (PPSIf False, False) : (_, False) : _ )
--- = output "//#elif" $ exec xs state
--- exec (Else : xs) state@( (_, False) : _ )
--- = output "//#else" $ exec xs ((PPSElse, False) : state)
exec (Text t : xs) state@( (_, False) : _ )
= output ("//T " ++ t) $ exec xs state
exec (Endif : xs) (_ : state)
@@ -139,16 +135,6 @@
return (t : moreText)
-test = putStrLn $ execute "test" $ parseDirectives
- "#include <foo>\n\
- \blah\n\
- \foo bar\n\
- \#if 1\n\
- \baz\n\
- \#else\n\
- \quux\n\
- \#endif\n"
-
unblockComments ('/' : '*' : xs) = "/*" ++ handleComment xs
where handleComment ('*' : '/' : xs) = "*/" ++ unblockComments xs
handleComment ('\n' : xs) = "*/\n/*" ++ handleComment xs
@@ -159,7 +145,20 @@
parseDirectives = map (\l -> case parse line "" l of
Left e -> Text $ l ++ "// " ++ show (show
e)
- Right x -> x) . lines . unblockComments
+ Right x -> x) . lines . unblockComments
+
+preprocess fn f = execute fn $ parseDirectives f
+
+{-
+test = putStrLn $ execute "test" $ parseDirectives
+ "#include <foo>\n\
+ \blah\n\
+ \foo bar\n\
+ \#if 1\n\
+ \baz\n\
+ \#else\n\
+ \quux\n\
+ \#endif\n"
test2 fn = do
-- f <- readFile
$ "/System/Library/Frameworks/Foundation.framework/Versions/C/Headers/" ++
fn
@@ -172,7 +171,4 @@
-- putStrLn $
putStrLn fn
print $ length $ execute fn $ parseDirectives f
-
-
-preprocess fn f = execute fn $ parseDirectives f
-
+-}
\ No newline at end of file
Modified: trunk/hoc/InterfaceGenerator2/ResolveAndZap.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/ResolveAndZap.hs (original)
+++ trunk/hoc/InterfaceGenerator2/ResolveAndZap.hs Thu Sep 25 16:35:43 2008
@@ -103,15 +103,7 @@
_ -> zapAndReportBrokenReferences progress pile'
where
- {-
-zapAndReportFailedTypes :: ProgressReporter -> EntityPile -> Messages
EntityPile
-
-zapAndReportFailedTypes progress entityPile
- = return entityPile
- where
-
- -}
-
+zapAndReportFailedTypes :: ProgressReporter -> EntityPile -> Messages
EntityPile
zapAndReportFailedTypes progress entityPile
= zapAndReportWith worker progress entityPile
where
@@ -120,7 +112,7 @@
>> return x
reportUnconvertedType t@(UnconvertedType ctype)
- = message $ text "Coudn't convert type" -- <+> text (show
ctype)
+ = message $ text "Coudn't convert type" <+> text (show ctype)
reportUnconvertedType t
= return ()
|
