Menu
▾
▴
[hoc-cvs] [hoc commit] r309 - trunk/hoc/InterfaceGenerator2
|
From: <cod...@go...> - 2008-09-21 20:45:33
|
Author: wol...@gm...
Date: Sun Sep 21 13:44:33 2008
New Revision: 309
Added:
trunk/hoc/InterfaceGenerator2/RenameClashingIdentifiers.hs
Modified:
trunk/hoc/InterfaceGenerator2/BinaryInstances.hs
trunk/hoc/InterfaceGenerator2/BuildEntities.hs
trunk/hoc/InterfaceGenerator2/Entities.hs
trunk/hoc/InterfaceGenerator2/ShuffleInstances.hs
Log:
Add some code to automatically resolve some name conflicts, e.g.
"move:" and "move" in the same module.
It used to be necessary to add those in binding-script for the bindings
to compile.
Modified: trunk/hoc/InterfaceGenerator2/BinaryInstances.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/BinaryInstances.hs (original)
+++ trunk/hoc/InterfaceGenerator2/BinaryInstances.hs Sun Sep 21 13:44:33
2008
@@ -159,8 +159,8 @@
_ -> fail "no parse"
instance Binary Entities.Entity where
- put (Entity a b c d) = put a >> put b >> put c >> put d
- get = get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> return
(Entity a b c d)
+ put (Entity a b c d e) = put a >> put b >> put c >> put d >> put e
+ get = get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> get >>= \e
-> return (Entity a b c d e)
instance Binary Entities.EntityPile where
put (EntityPile a b c) = put a >> put b >> put c
Modified: trunk/hoc/InterfaceGenerator2/BuildEntities.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/BuildEntities.hs (original)
+++ trunk/hoc/InterfaceGenerator2/BuildEntities.hs Sun Sep 21 13:44:33 2008
@@ -57,6 +57,7 @@
newEntity $ Entity {
eName = CName $ BS.pack typeName,
eHaskellName = assertHaskellTypeName $ BS.pack
typeName,
+ eAlternateHaskellNames = [],
eInfo = AdditionalTypeEntity,
eModule = LocalModule $ BS.pack moduleName
}
@@ -92,6 +93,7 @@
entity <- newEntity $ Entity {
eName = SelectorName $ BS.pack name,
eHaskellName = BS.pack mangled,
+ eAlternateHaskellNames = moreMangled,
eInfo = SelectorEntity (UnconvertedType (kind,
sel')),
eModule = LocalModule modName
}
@@ -104,6 +106,10 @@
mangled = case mapped of
Just x -> x
Nothing -> mangleSelectorName name
+ moreMangled = map BS.pack $ case mapped of
+ Just _ -> [mangleSelectorName name,
mangleSelectorNameWithUnderscores name]
+ Nothing -> [mangleSelectorNameWithUnderscores name]
+
replacement = Map.lookup name (soChangedSelectors
selectorOptions)
sel' = case replacement of
Just x -> x
@@ -141,6 +147,7 @@
= newEntity $ Entity {
eName = SelectorInstanceName classEntity
selectorEntity factory,
eHaskellName = BS.empty,
+ eAlternateHaskellNames = [],
eInfo = MethodEntity,
eModule = LocalModule modName
}
@@ -151,6 +158,7 @@
classEntity <- newEntity $ Entity {
eName = CName $ BS.pack clsName,
eHaskellName = getName clsName (nameToUppercase
clsName),
+ eAlternateHaskellNames = [],
eInfo = ClassEntity (fmap (DelayedClassLookup .
BS.pack) mbSuper),
eModule = LocalModule modName
}
@@ -159,6 +167,7 @@
eName = ProtocolAdoptionName
(DelayedClassLookup $ BS.pack clsName)
(DelayedProtocolLookup $ BS.pack
protocol),
eHaskellName = BS.empty,
+ eAlternateHaskellNames = [],
eInfo = ProtocolAdoptionEntity,
eModule = LocalModule modName
}
@@ -173,6 +182,7 @@
eName = ProtocolAdoptionName
(DelayedClassLookup $ BS.pack clsName)
(DelayedProtocolLookup $ BS.pack
protocol),
eHaskellName = BS.empty,
+ eAlternateHaskellNames = [],
eInfo = ProtocolAdoptionEntity,
eModule = LocalModule modName
}
@@ -187,6 +197,7 @@
newEntity $ Entity {
eName = ProtocolName $ BS.pack protoName,
eHaskellName = getName protoName (nameToUppercase
protoName ++ "Protocol"),
+ eAlternateHaskellNames = [],
eInfo = ProtocolEntity (map
(DelayedProtocolLookup . BS.pack) protocols)
selectors,
eModule = LocalModule modName
@@ -210,6 +221,7 @@
newEntity $ Entity {
eName = CName $ BS.pack name,
eHaskellName = getName name (nameToUppercase name),
+ eAlternateHaskellNames = [],
eInfo = TypeSynonymEntity (UnconvertedType ct),
eModule = LocalModule modName
}
@@ -220,6 +232,7 @@
newEntity $ Entity {
eName = CName $ BS.pack name,
eHaskellName = getName name (nameToLowercase name),
+ eAlternateHaskellNames = [],
eInfo = ExternVarEntity (UnconvertedType ct),
eModule = LocalModule modName
}
@@ -230,6 +243,7 @@
newEntity $ Entity {
eName = CName $ BS.pack name,
eHaskellName = getName name (nameToLowercase name),
+ eAlternateHaskellNames = [],
eInfo = ExternFunEntity (UnconvertedType
(PlainSelector, sel)),
eModule = LocalModule modName
}
@@ -259,6 +273,7 @@
newEntity $ Entity {
eName = CName $ BS.pack name,
eHaskellName = getName name (nameToUppercase
name),
+ eAlternateHaskellNames = [],
eInfo = EnumEntity True values',
eModule = LocalModule modName
}
@@ -267,12 +282,14 @@
newEntity $ Entity {
eName = Anonymous,
eHaskellName = BS.empty,
+ eAlternateHaskellNames = [],
eInfo = EnumEntity False values',
eModule = LocalModule modName
}
newEntity $ Entity {
eName = CName $ BS.pack name,
eHaskellName = getName name (nameToUppercase
name),
+ eAlternateHaskellNames = [],
eInfo = TypeSynonymEntity (UnconvertedType
cTypeInt),
eModule = LocalModule modName
}
@@ -283,6 +300,7 @@
newEntity $ Entity {
eName = Anonymous,
eHaskellName = BS.empty,
+ eAlternateHaskellNames = [],
eInfo = EnumEntity complete values',
eModule = LocalModule modName
}
@@ -322,6 +340,7 @@
newEntity $ Entity {
eName = Anonymous,
eHaskellName = BS.empty,
+ eAlternateHaskellNames = [],
eInfo = AdditionalCodeEntity
2
exports
@@ -332,6 +351,7 @@
newEntity $ Entity {
eName = Anonymous,
eHaskellName = BS.empty,
+ eAlternateHaskellNames = [],
eInfo = AdditionalCodeEntity
9
[]
Modified: trunk/hoc/InterfaceGenerator2/Entities.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Entities.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Entities.hs Sun Sep 21 13:44:33 2008
@@ -75,6 +75,7 @@
data Entity = Entity {
eName :: Name,
eHaskellName :: ByteString,
+ eAlternateHaskellNames :: [ByteString],
eInfo :: EntityInfo,
eModule :: Module
}
Added: trunk/hoc/InterfaceGenerator2/RenameClashingIdentifiers.hs
==============================================================================
--- (empty file)
+++ trunk/hoc/InterfaceGenerator2/RenameClashingIdentifiers.hs Sun Sep 21
13:44:33 2008
@@ -0,0 +1,148 @@
+module RenameClashingIdentifiers( renameClashingIdentifiers ) where
+
+import Entities
+import qualified Data.Map as Map
+import Data.List( sort, sortBy, groupBy, nub )
+
+import Debug.Trace
+import Data.ByteString.Char8(ByteString)
+import qualified Data.ByteString.Char8 as BS
+
+renameClashingIdentifiers :: EntityPile -> EntityPile
+
+{-data Namespace = SelectorNamespace
+ | UnimportantNamespace
+ deriving (Ord, Eq, Show)
+
+getNamespace (SelectorEntity _) = SelectorNamespace
+getNamespace _ = UnimportantNamespace
+-}
+
+{-
+renameClashingIdentifiers ep
+ = ep { epEntities = Map.fromList $
+ concat $
+ map resolveClash $
+ groupedByModuleAndName }
+ where
+ groupedByModuleAndName
+ = Map.toList $ Map.fromListWith (++) $
+ [ ( (eModule entity, eHaskellName entity{-, getNamespace $
eInfo entity-} ),
+ [(entityID, entity)] )
+ | (entityID, entity) <- Map.toList $ epEntities ep ]
+
+
+ resolveClash ( _, [x] ) = [x]
+ resolveClash ( (mod, name{-, UnimportantNamespace-} ), entities )
+ = entities
+ resolveClash ( (mod, name{-, namespace-} ), entities )
+ | BS.null name = entities
+ resolveClash ( (mod, name{-, namespace-}), entities )
+ = trace (show (mod,name, map (show . eName . snd) entities)) $
+ case possibleCombos of
+ (combo : _)
+ -> trace (show combo) $
+ zipWith renameEntity entities combo
+ where
+ names = map possibleNamesForEntity entities
+
+ possibleNamesFor (LocalID _, e)
+ = eHaskellName e : eAlternateHaskellNames e
+ ++ [ eHaskellName e `BS.append` BS.pack ("_" ++ show
i) | i <- [1..] ]
+ possibleNamesFor (_, e)
+ = [eHaskellName e]
+
+ possibleCombos = filter checkCombo $ nameCombinations names
+
+ checkCombo = all ((==1) . length) . group . sort
+
+ renameEntity (entityID, entity) newName
+ = (entityID, entity { eHaskellName = newName })
+-}
+
+
+renameClashingIdentifiers ep
+ = ep { epEntities = Map.fromList $
+ concatMap handleName $
+ groupedByName }
+ where
+ groupedByName :: [ (ByteString, [ (EntityID, Entity) ]) ]
+ groupedByName
+ = Map.toList $ Map.fromListWith (++) $
+ [ ( eHaskellName entity, [(entityID, entity)] )
+ | (entityID, entity) <- Map.toList $ epEntities ep ]
+
+ handleName :: (ByteString, [ (EntityID, Entity) ]) -> [ (EntityID,
Entity) ]
+ handleName (hName, entities)
+ | BS.null hName
+ = entities
+ | null clashes
+ = entities
+ | otherwise
+ = concat $ zipWith renameEntities (map (map snd)
groupedEntities) $ head possibleCombos
+ where
+ groupedEntities =
+ groupByFst $
+ sortBy (\a b -> compare (fst a) (fst b))
+ [ (originalEntityID e , e) | e <- entities ]
+
+ names = map (possibleNamesFor . head) groupedEntities where
+ possibleNamesFor (LocalEntity _, (_, e))
+ = eHaskellName e : eAlternateHaskellNames e
+ ++ [ eHaskellName e `BS.append` BS.pack ("_" ++
show i) | i <- [1..] ]
+ possibleNamesFor (_, (_, e))
+ = [eHaskellName e]
+
+ possibleCombos = filter checkCombo $ nameCombinations names
+
+ clashes :: [ [Int] ]
+ clashes =
+ filter ( (> 1) . length ) $
+ map nub $
+ map (map snd) $ groupByFst $ sort $
+ --map fst $ (\x -> if BS.unpack hName == "action"
then trace (show x) x else x) $
+ [ (eModule e, index) --, (eid, e))
+ | (index, entities) <- zip [0..] groupedEntities,
+ (_, (eid, e)) <- entities ]
+
+ checkCombo newNames
+ = all checkClash clashes
+ where
+ checkClash clash =
+ trace (show (clash, newNames)) $ nub
toBeTested == toBeTested
+ where toBeTested = extract clash newNames
+
+ extract indices xs = map (xs!!) indices
+ {-extract [] i0 _ = []
+ extract (index : indices) i0 xs
+ = (xs !! (index - i0))
+ : extract indices
+ (index + 1)
+ (drop (index - i0 + 1) xs)-}
+
+ renameEntity (entityID, entity) newName
+ = (entityID, entity { eHaskellName = newName })
+ renameEntities entities newName
+ = map (flip renameEntity newName) entities
+
+ originalEntityID (_, Entity { eInfo = ReexportEntity entityID' })
+ = originalEntityID (entityID', lookupEntity "originalEntityID"
entityID' ep)
+ originalEntityID (entityID, entity)
+ = entityID
+
+ groupByFst :: Eq a => [(a,b)] -> [[(a,b)]]
+ groupByFst = groupBy (\a b -> fst a == fst b)
+
+nameCombinations names = concat $ takeWhile (not . null) $ map (f names)
[0..]
+ where
+ f [] i = return []
+ f [ns] i = do
+ lastName <- take 1 $ drop i ns
+ return [lastName]
+ f (ns:nss) i = do
+ (chosenIndex, chosenName) <- zip [0..i] ns
+ moreChosenNames <- f nss (i - chosenIndex)
+ return (chosenName : moreChosenNames)
+
+
+-- (e1_n1 | e1_n2 | e1_n3) & (e2_n1 | e2_n2) & (!e1_n1 | !e2_n1) & (!e1_n2
| !e2_n2)
\ No newline at end of file
Modified: trunk/hoc/InterfaceGenerator2/ShuffleInstances.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/ShuffleInstances.hs (original)
+++ trunk/hoc/InterfaceGenerator2/ShuffleInstances.hs Sun Sep 21 13:44:33
2008
@@ -37,6 +37,7 @@
= newEntity $ Entity {
eName = SelectorInstanceName cls sel False,
eHaskellName = BS.empty,
+ eAlternateHaskellNames = [],
eInfo = MethodEntity,
eModule = eModule entity
}
@@ -45,6 +46,7 @@
= newEntity $ Entity {
eName = ProtocolAdoptionName cls proto,
eHaskellName = BS.empty,
+ eAlternateHaskellNames = [],
eInfo = ProtocolAdoptionEntity,
eModule = eModule entity
}
|
