Menu
▾
▴
[hoc-cvs] hoc/InterfaceGenerator BindingScript.hs,1.8,1.9 CTypeToHaskell.hs,1.7,1.8 Enums.hs,1.4,1.5 ExportModule.hs,1.8,1.9 Main.hs,1.7,1.8 PrepareDeclarations.hs,1.13,1.14
|
From: Wolfgang T. <wth...@us...> - 2005-10-05 02:56:06
|
Update of /cvsroot/hoc/hoc/InterfaceGenerator In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv4594 Modified Files: BindingScript.hs CTypeToHaskell.hs Enums.hs ExportModule.hs Main.hs PrepareDeclarations.hs Log Message: Use Data.Map instead of Data.FiniteMap. Patch contributed by David Christensen <dw...@dw...>. Index: PrepareDeclarations.hs =================================================================== RCS file: /cvsroot/hoc/hoc/InterfaceGenerator/PrepareDeclarations.hs,v retrieving revision 1.13 retrieving revision 1.14 diff -u -d -r1.13 -r1.14 --- PrepareDeclarations.hs 27 Sep 2005 11:55:22 -0000 1.13 +++ PrepareDeclarations.hs 5 Oct 2005 02:55:49 -0000 1.14 @@ -12,6 +12,7 @@ import CTypeToHaskell import Headers(HeaderInfo(..), ModuleName) import Enums +import Data.List (foldl') import HOC.NameCaseChange import HOC.SelectorNameMangling(mangleSelectorName) @@ -19,7 +20,7 @@ import Control.Monad(when) import Data.Set(Set, mkSet, setToList, union, minusSet, unionManySets, emptySet, elementOf) -import Data.FiniteMap +import qualified Data.Map as Map import qualified Data.HashTable as HashTable import Data.Maybe(maybeToList, fromMaybe, mapMaybe) import Data.List(partition,isPrefixOf) @@ -30,9 +31,9 @@ pdCleanClassInfoHash :: HashTable.HashTable String ClassInfo, {- used read only -} pdAllInstanceSels :: [(ClassInfo, [(MangledSelector, SelectorLocation)])], pdAllClassSels :: [(ClassInfo, [(MangledSelector, SelectorLocation)])], - pdEnumTypeDefinitions :: FiniteMap ModuleName [EnumType], - pdExternVarDeclarations :: FiniteMap ModuleName [(HType, String, String)], - pdExternFunDeclarations :: FiniteMap ModuleName [MangledSelector], + pdEnumTypeDefinitions :: Map.Map ModuleName [EnumType], + pdExternVarDeclarations :: Map.Map ModuleName [(HType, String, String)], + pdExternFunDeclarations :: Map.Map ModuleName [MangledSelector], pdTypeEnvironment :: TypeEnvironment } @@ -49,10 +50,10 @@ ciProtocols :: Set String, ciNewProtocols :: Set String, ciDefinedIn :: ModuleName, - ciInstanceMethods :: FiniteMap Selector SelectorLocation, - ciClassMethods :: FiniteMap Selector SelectorLocation, - ciNewInstanceMethods :: FiniteMap Selector SelectorLocation, - ciNewClassMethods :: FiniteMap Selector SelectorLocation + ciInstanceMethods :: Map.Map Selector SelectorLocation, + ciClassMethods :: Map.Map Selector SelectorLocation, + ciNewInstanceMethods :: Map.Map Selector SelectorLocation, + ciNewClassMethods :: Map.Map Selector SelectorLocation } deriving(Show) @@ -63,9 +64,9 @@ ciSuper = fmap nameToUppercase super, ciProtocols = mkSet (map nameToUppercase protocols), ciDefinedIn = moduleName, - ciInstanceMethods = listToFM [ (sel, SelectorLocation moduleName moduleName) + ciInstanceMethods = Map.fromList [ (sel, SelectorLocation moduleName moduleName) | InstanceMethod sel <- methods ], - ciClassMethods = listToFM [ (sel, SelectorLocation moduleName moduleName) + ciClassMethods = Map.fromList [ (sel, SelectorLocation moduleName moduleName) | ClassMethod sel <- methods ], ciNewProtocols = error "ciNewProtocols 1", ciNewInstanceMethods = error "ciNewInstanceMethods 1", @@ -78,9 +79,9 @@ ciSuper = Nothing, ciProtocols = mkSet (map nameToUppercase protocols), ciDefinedIn = moduleName, - ciInstanceMethods = listToFM [ (sel, SelectorLocation moduleName cantHappen) + ciInstanceMethods = Map.fromList [ (sel, SelectorLocation moduleName cantHappen) | InstanceMethod sel <- methods ], - ciClassMethods = listToFM [ (sel, SelectorLocation moduleName cantHappen) + ciClassMethods = Map.fromList [ (sel, SelectorLocation moduleName cantHappen) | ClassMethod sel <- methods ], ciNewProtocols = error "ciNewProtocols 2", ciNewInstanceMethods = error "ciNewInstanceMethods 2", @@ -162,35 +163,35 @@ cleanClassInfo' info mbSuperInfo protocolInfos | ciProtocol info = info { - ciInstanceMethods = foldl1 plusFM $ + ciInstanceMethods = foldl1 (flip Map.union) $ map ciInstanceMethods $ info : protocolInfos, - ciClassMethods = foldl1 plusFM $ + ciClassMethods = foldl1 (flip Map.union) $ map ciClassMethods $ info : protocolInfos, ciNewInstanceMethods = - ciInstanceMethods info `minusFM` + ciInstanceMethods info `Map.difference` (unionProtocols ciInstanceMethods), ciNewClassMethods = - ciClassMethods info `minusFM` + ciClassMethods info `Map.difference` (unionProtocols ciClassMethods), ciProtocols = ciProtocols info `union` protocolsAdoptedByAdoptedProtocols, ciNewProtocols = ciProtocols info `minusSet` protocolsAdoptedByAdoptedProtocols } | otherwise = info { - ciInstanceMethods = foldl1 plusFM $ + ciInstanceMethods = foldl1 (flip Map.union) $ map ciInstanceMethods $ info : (maybeToList mbSuperInfo) ++ protocolInfos, - ciClassMethods = foldl1 plusFM $ + ciClassMethods = foldl1 (flip Map.union) $ map ciClassMethods $ info : (maybeToList mbSuperInfo) ++ protocolInfos, - ciNewInstanceMethods = (ciInstanceMethods info `plusFM_proto` + ciNewInstanceMethods = (ciInstanceMethods info `add_protocol` (unionProtocols ciInstanceMethods)) - `minusFM` super ciInstanceMethods, - ciNewClassMethods = (ciClassMethods info `plusFM_proto` + `Map.difference` super ciInstanceMethods, + ciNewClassMethods = (ciClassMethods info `add_protocol` (unionProtocols ciClassMethods)) - `minusFM` super ciClassMethods, + `Map.difference` super ciClassMethods, ciProtocols = ciProtocols info `union` protocolsAdoptedByAdoptedProtocols `union` protocolsAdoptedBySuper, @@ -201,10 +202,10 @@ where super extract = case mbSuperInfo of Just superInfo -> extract superInfo - Nothing -> emptyFM - unionProtocols extract = foldl plusFM emptyFM $ + Nothing -> Map.empty + unionProtocols extract = foldl (flip Map.union) Map.empty $ map extract protocolInfos - plusFM_proto cls proto = plusFM_C (\(SelectorLocation _ inst) + add_protocol cls proto = Map.unionWith (\(SelectorLocation _ inst) (SelectorLocation def _) -> SelectorLocation def {-inst-} (ciDefinedIn info)) -- * All selectors that are part of a protocol @@ -214,8 +215,8 @@ -- Otherwise, the context for the protocol instance declaration -- won't be available when the protocol is adopted. cls - (mapFM (\sel (SelectorLocation def _) - -> SelectorLocation def (ciDefinedIn info)) + (Map.map (\(SelectorLocation def _) + -> (SelectorLocation def (ciDefinedIn info))) proto) protocolsAdoptedByAdoptedProtocols = unionManySets $ map ciProtocols $ @@ -242,7 +243,7 @@ | (mod, SelectorList (Interface name _ _) _) <- allDecls ] (enumNamesAndLocations, enumDefinitions) = extractEnums bindingScript modules - typeEnv = TypeEnvironment $ listToFM $ + typeEnv = TypeEnvironment $ Map.fromList $ classNames ++ [ (name, (PlainTypeName, mod)) | (name, mod) <- enumNamesAndLocations ++ bsAdditionalTypes bindingScript ] @@ -285,18 +286,18 @@ } funDecl _ = Nothing - extractDecls f = listToFM $ + extractDecls f = Map.fromList $ map (\(HeaderInfo mod _ decls) -> (mod, mapMaybe f decls)) $ modules mangleSelectors factory clsName sels = mapMaybe (\(sel, location) -> do {- Maybe -} let name = selName sel - mapped = lookupFM (soNameMappings selectorOptions) name + mapped = Map.lookup name (soNameMappings selectorOptions) mangled = case mapped of Just x -> x Nothing -> mangleSelectorName name - replacement = lookupFM (soChangedSelectors selectorOptions) name + replacement = Map.lookup name (soChangedSelectors selectorOptions) sel' = case replacement of Just x -> x Nothing -> sel @@ -320,7 +321,7 @@ msMangled = mangled, msType = typ }, location) - ) $ fmToList sels + ) $ Map.toList sels where selectorOptions = getSelectorOptions bindingScript clsName @@ -334,3 +335,6 @@ pdExternFunDeclarations = externFunDeclarations, pdTypeEnvironment = typeEnv } + +addListToFM_C c m kvs = foldl' add m kvs + where add m' (k,v) = Map.insertWith (flip c) k v m' Index: Enums.hs =================================================================== RCS file: /cvsroot/hoc/hoc/InterfaceGenerator/Enums.hs,v retrieving revision 1.4 retrieving revision 1.5 diff -u -d -r1.4 -r1.5 --- Enums.hs 29 Jul 2005 03:39:44 -0000 1.4 +++ Enums.hs 5 Oct 2005 02:55:49 -0000 1.5 @@ -13,12 +13,12 @@ import Data.Char ( toUpper ) import Data.Maybe ( mapMaybe ) -import Data.FiniteMap ( FiniteMap, listToFM ) +import qualified Data.Map as Map ( Map, fromList ) import Data.Set ( Set, mkSet, elementOf ) import Text.PrettyPrint.HughesPJ import Debug.Trace -extractEnums :: BindingScript -> [HeaderInfo] -> ([(String, ModuleName)], FiniteMap ModuleName [EnumType]) +extractEnums :: BindingScript -> [HeaderInfo] -> ([(String, ModuleName)], Map.Map ModuleName [EnumType]) data EnumType = EnumType (Maybe String) [(String, Integer)] deriving(Show) @@ -26,7 +26,7 @@ extractEnums bs headers = ( [ (name, mod) | (mod, types) <- enums, Just name <- map enumName types ] - , listToFM enums + , Map.fromList enums ) where enums = [ (moduleName, mapMaybe (filterEnumType bs . extractEnumType) decls) | HeaderInfo moduleName _ decls <- headers ] Index: ExportModule.hs =================================================================== RCS file: /cvsroot/hoc/hoc/InterfaceGenerator/ExportModule.hs,v retrieving revision 1.8 retrieving revision 1.9 diff -u -d -r1.8 -r1.9 --- ExportModule.hs 27 Sep 2005 11:55:22 -0000 1.8 +++ ExportModule.hs 5 Oct 2005 02:55:49 -0000 1.9 @@ -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, lookupWithDefaultFM) +import qualified Data.Map as Map (lookup, findWithDefault) import Text.PrettyPrint.HughesPJ getModuleDependencies :: PreparedDeclarations -> ModuleName -> IO [ModuleName] @@ -187,8 +187,8 @@ | proto <- setToList $ ciNewProtocols ci] | ci <- definedClassInfos, not (ciProtocol ci) ] - varDeclarations = lookupWithDefaultFM allVarDeclarations [] moduleName - funDeclarations = lookupWithDefaultFM allFunDeclarations [] moduleName + varDeclarations = Map.findWithDefault [] moduleName allVarDeclarations + funDeclarations = Map.findWithDefault [] moduleName allFunDeclarations let mentionedTypeNames = nub $ concatMap (mentionedTypes.msType) (selDefinitions ++ funDeclarations) @@ -231,7 +231,7 @@ <- additionalCodeAboveForward ++ additionalCodeBelowForward ] - let enumDefinitions = fromMaybe [] $ lookupFM allEnumDefinitions moduleName + let enumDefinitions = fromMaybe [] $ Map.lookup moduleName allEnumDefinitions let anythingGoingOn = not $ and [null methodInstances, null exportedClasses, Index: Main.hs =================================================================== RCS file: /cvsroot/hoc/hoc/InterfaceGenerator/Main.hs,v retrieving revision 1.7 retrieving revision 1.8 diff -u -d -r1.7 -r1.8 --- Main.hs 27 Sep 2005 11:55:22 -0000 1.7 +++ Main.hs 5 Oct 2005 02:55:49 -0000 1.8 @@ -2,7 +2,7 @@ import Control.Exception(evaluate) -import Data.FiniteMap +import qualified Data.Map as Map import qualified Data.HashTable as HashTable import Data.List(isPrefixOf,isSuffixOf,partition) import Data.Maybe(fromMaybe,mapMaybe,isJust,isNothing,catMaybes,maybeToList) @@ -24,7 +24,7 @@ writeMasterModule masterModuleName realModuleNames selNamesList = do - let conflictingDecls = listToFM $ + let conflictingDecls = Map.fromList $ map (\(mod,sels) -> (mod, concatMap idsForSel sels)) $ groupByFirst $ concatMap (\(selName,(cnt,exporters)) -> @@ -33,7 +33,7 @@ else [] ) $ selNamesList - hidingClause mod = case lookupFM conflictingDecls mod of + hidingClause mod = case Map.lookup mod conflictingDecls of Just decls -> text "hiding" <+> parens (sep $ punctuate comma $ map text $ decls) Nothing -> empty Index: CTypeToHaskell.hs =================================================================== RCS file: /cvsroot/hoc/hoc/InterfaceGenerator/CTypeToHaskell.hs,v retrieving revision 1.7 retrieving revision 1.8 diff -u -d -r1.7 -r1.8 --- CTypeToHaskell.hs 27 Sep 2005 11:55:22 -0000 1.7 +++ CTypeToHaskell.hs 5 Oct 2005 02:55:49 -0000 1.8 @@ -20,7 +20,7 @@ import HOC.NameCaseChange import Control.Monad(when) -import Data.FiniteMap +import qualified Data.Map as Map import Data.Maybe(mapMaybe) import Text.PrettyPrint @@ -29,24 +29,24 @@ data TypeNameKind = ClassTypeName | PlainTypeName deriving (Show) -newtype TypeEnvironment = TypeEnvironment (FiniteMap String (TypeNameKind, ModuleName)) +newtype TypeEnvironment = TypeEnvironment (Map.Map String (TypeNameKind, ModuleName)) -- (Set String) -- known classes -- (Set String) -- other known types isClassType (TypeEnvironment env) name = - case lookupFM env (nameToUppercase name) of + case Map.lookup (nameToUppercase name) env of Just (ClassTypeName, _) -> True _ -> False isPlainType (TypeEnvironment env) name = - case lookupFM env (nameToUppercase name) of + case Map.lookup (nameToUppercase name) env of Just (PlainTypeName, _) -> True _ -> False typeDefinedIn (TypeEnvironment env) name = - case lookupFM env (nameToUppercase name) of + case Map.lookup (nameToUppercase name) env of Just (_, loc) -> loc -lookupTypeEnv (TypeEnvironment env) name = lookupFM env name +lookupTypeEnv (TypeEnvironment env) name = Map.lookup name env data HTypeTerm = Con String | HTypeTerm :$ HTypeTerm | Var String deriving(Eq,Ord) Index: BindingScript.hs =================================================================== RCS file: /cvsroot/hoc/hoc/InterfaceGenerator/BindingScript.hs,v retrieving revision 1.8 retrieving revision 1.9 diff -u -d -r1.8 -r1.9 --- BindingScript.hs 31 Mar 2005 15:30:19 -0000 1.8 +++ BindingScript.hs 5 Oct 2005 02:55:49 -0000 1.9 @@ -12,8 +12,8 @@ import qualified Parser(selector) import Control.Monad(when) -import Data.FiniteMap -import Data.Set hiding (map, null) +import qualified Data.Map as Map +import Data.Set(Set, union, mkSet, setToList) import Data.List(intersperse) import Text.ParserCombinators.Parsec.Language(haskellStyle) @@ -25,29 +25,29 @@ bsHiddenEnums :: Set String, bsTopLevelOptions :: SelectorOptions, bsAdditionalTypes :: [(String, String)], - bsClassSpecificOptions :: FiniteMap String SelectorOptions + bsClassSpecificOptions :: Map.Map String SelectorOptions } data SelectorOptions = SelectorOptions { - soNameMappings :: FiniteMap String String, + soNameMappings :: Map.Map String String, soCovariantSelectors :: Set String, soHiddenSelectors :: Set String, - soChangedSelectors :: FiniteMap String Selector + soChangedSelectors :: Map.Map String Selector } getSelectorOptions :: BindingScript -> String -> SelectorOptions getSelectorOptions bindingScript clsName = - case lookupFM (bsClassSpecificOptions bindingScript) clsName of + case Map.lookup clsName (bsClassSpecificOptions bindingScript) of Just opt -> SelectorOptions { - soNameMappings = soNameMappings top - `plusFM` soNameMappings opt, - soCovariantSelectors = soCovariantSelectors top - `union` soCovariantSelectors opt, - soHiddenSelectors = soHiddenSelectors top - `union` soHiddenSelectors opt, - soChangedSelectors = soChangedSelectors top - `plusFM` soChangedSelectors opt + soNameMappings = soNameMappings opt + `Map.union` soNameMappings top, + soCovariantSelectors = soCovariantSelectors opt + `union` soCovariantSelectors top, + soHiddenSelectors = soHiddenSelectors opt + `union` soHiddenSelectors top, + soChangedSelectors = soChangedSelectors opt + `Map.union` soChangedSelectors top } Nothing -> top where @@ -78,12 +78,12 @@ extractSelectorOptions statements = SelectorOptions { - soNameMappings = listToFM [ (objc, haskell) + soNameMappings = Map.fromList [ (objc, haskell) | Rename objc haskell <- statements ], soCovariantSelectors = mkSet $ [ ident | Covariant ident <- statements ], soHiddenSelectors = mkSet $ [ ident | Hide ident <- statements ], - soChangedSelectors = listToFM [ (selName sel, sel) + soChangedSelectors = Map.fromList [ (selName sel, sel) | ReplaceSelector sel <- statements ] } @@ -144,7 +144,7 @@ bsHiddenEnums = mkSet [ ident | HideEnum ident <- statements ], bsTopLevelOptions = extractSelectorOptions statements, bsAdditionalTypes = [ (typ, mod) | Type typ mod <- statements ], - bsClassSpecificOptions = listToFM [ (cls, opt) + bsClassSpecificOptions = Map.fromList [ (cls, opt) | ClassSpecific cls opt <- statements ] } |
