Menu
▾
▴
[hoc-cvs] [hoc commit] r327 - trunk/hoc/InterfaceGenerator2
|
From: <cod...@go...> - 2008-10-01 22:54:29
|
Author: wol...@gm...
Date: Wed Oct 1 15:53:54 2008
New Revision: 327
Added:
trunk/hoc/InterfaceGenerator2/SrcPos.hs
Modified:
trunk/hoc/InterfaceGenerator2/BuildEntities.hs
trunk/hoc/InterfaceGenerator2/Entities.hs
trunk/hoc/InterfaceGenerator2/HackEnumNames.hs
trunk/hoc/InterfaceGenerator2/Headers.hs
trunk/hoc/InterfaceGenerator2/Parser.hs
trunk/hoc/InterfaceGenerator2/ParserBase.hs
trunk/hoc/InterfaceGenerator2/ResolveAndZap.hs
trunk/hoc/InterfaceGenerator2/ShuffleInstances.hs
trunk/hoc/InterfaceGenerator2/SyntaxTree.hs
Log:
Add source location information to parse tree and entity pile.
Use it when reporting skipped entities.
Modified: trunk/hoc/InterfaceGenerator2/BuildEntities.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/BuildEntities.hs (original)
+++ trunk/hoc/InterfaceGenerator2/BuildEntities.hs Wed Oct 1 15:53:54 2008
@@ -8,6 +8,7 @@
import Traversals
import BindingScript
import SyntaxTree
+import SrcPos
import CTypeToHaskell
import Headers
@@ -17,7 +18,7 @@
import Control.Monad.State
import Data.Char ( isUpper, isLower, isAlphaNum, toUpper )
import Data.List ( groupBy, isPrefixOf )
-import Data.Maybe ( fromMaybe, catMaybes )
+import Data.Maybe ( fromMaybe )
import System.Directory ( doesFileExist )
import qualified Data.ByteString.Char8 as BS
@@ -60,7 +61,8 @@
eHaskellName = assertHaskellTypeName $ BS.pack
typeName,
eAlternateHaskellNames = [],
eInfo = AdditionalTypeEntity,
- eModule = LocalModule $ BS.pack moduleName
+ eModule = LocalModule $ BS.pack moduleName,
+ eSrcPos = AutoGeneratedPos
}
| (typeName, moduleName) <- bsAdditionalTypes
bindingScript,
BS.pack moduleName `Set.member` modNames
@@ -87,7 +89,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 pos factory modName _clsID clsName sel
= if hidden
then return []
else do
@@ -96,7 +98,8 @@
eHaskellName = BS.pack mangled,
eAlternateHaskellNames = moreMangled,
eInfo = SelectorEntity (UnconvertedType (kind,
sel')),
- eModule = LocalModule modName
+ eModule = LocalModule modName,
+ eSrcPos = pos
}
return $ [(entity, factory)]
where
@@ -129,16 +132,16 @@
&& (not $ isLower (b !! length a))
| otherwise = a == b
- makeEntitiesForSelectorListItem modName clsID clsName
(InstanceMethod sel)
- = makeSelectorEntity False modName clsID clsName sel
- makeEntitiesForSelectorListItem modName clsID clsName (ClassMethod
sel)
- = makeSelectorEntity True modName clsID clsName sel
- makeEntitiesForSelectorListItem modName _clsID _clsName (LocalDecl
decl)
- = makeEntity modName decl >> return []
- makeEntitiesForSelectorListItem modName clsID clsName
(PropertyDecl typ name attr)
+ makeEntitiesForSelectorListItem modName clsID clsName (pos,
InstanceMethod sel)
+ = makeSelectorEntity pos False modName clsID clsName sel
+ makeEntitiesForSelectorListItem modName clsID clsName (pos,
ClassMethod sel)
+ = makeSelectorEntity pos True modName clsID clsName sel
+ makeEntitiesForSelectorListItem modName _clsID _clsName (pos,
LocalDecl decl)
+ = makeEntity modName (pos, decl) >> return []
+ makeEntitiesForSelectorListItem modName clsID clsName (pos,
PropertyDecl typ name attr)
= do
- getter <- makeSelectorEntity False modName clsID clsName
getterSel
- setter <- makeSelectorEntity False modName clsID clsName
setterSel
+ getter <- makeSelectorEntity pos False modName clsID
clsName getterSel
+ setter <- makeSelectorEntity pos False modName clsID
clsName setterSel
return (getter ++ setter)
where
getterName = head $ [ n | Getter n <- attr ] ++ [ name ]
@@ -147,23 +150,24 @@
getterSel = Selector getterName typ [] False
setterSel = Selector setterName
(CTSimple "void") [typ] False
- makeEntitiesForSelectorListItem _modName _clsID _clsName (Required
_)
+ makeEntitiesForSelectorListItem _modName _clsID _clsName (pos,
Required _)
= return []
makeSelectorEntities modName clsID clsName items
= fmap concat $
mapM (makeEntitiesForSelectorListItem modName clsID clsName)
items
- makeSelectorInstance modName classEntity (selectorEntity, factory)
+ makeSelectorInstance pos modName classEntity (selectorEntity,
factory)
= newEntity $ Entity {
eName = SelectorInstanceName classEntity
selectorEntity factory,
eHaskellName = BS.empty,
eAlternateHaskellNames = [],
eInfo = MethodEntity,
- eModule = LocalModule modName
+ eModule = LocalModule modName,
+ eSrcPos = pos
}
- makeEntity modName (SelectorList (Interface clsName mbSuper
protocols) contents)
+ makeEntity modName (pos, SelectorList (Interface clsName mbSuper
protocols) contents)
| notHidden clsName
= do
classEntity <- newEntity $ Entity {
@@ -171,7 +175,8 @@
eHaskellName = getName clsName (nameToUppercase
clsName),
eAlternateHaskellNames = [],
eInfo = ClassEntity (fmap (DelayedClassLookup .
BS.pack) mbSuper),
- eModule = LocalModule modName
+ eModule = LocalModule modName,
+ eSrcPos = pos
}
flip mapM_ protocols $ \protocol ->
newEntity $ Entity {
@@ -180,12 +185,13 @@
eHaskellName = BS.empty,
eAlternateHaskellNames = [],
eInfo = ProtocolAdoptionEntity,
- eModule = LocalModule modName
+ eModule = LocalModule modName,
+ eSrcPos = pos
}
selectors <- makeSelectorEntities modName classEntity
clsName contents
- mapM (makeSelectorInstance modName classEntity) selectors
+ mapM (makeSelectorInstance pos modName classEntity)
selectors
return ()
- makeEntity modName (SelectorList (Category clsName _catName
protocols) contents)
+ makeEntity modName (pos, SelectorList (Category clsName _catName
protocols) contents)
= do
let classEntity = DelayedClassLookup $ BS.pack clsName
flip mapM_ protocols $ \protocol ->
@@ -195,12 +201,13 @@
eHaskellName = BS.empty,
eAlternateHaskellNames = [],
eInfo = ProtocolAdoptionEntity,
- eModule = LocalModule modName
+ eModule = LocalModule modName,
+ eSrcPos = pos
}
selectors <- makeSelectorEntities modName classEntity
clsName contents
- mapM (makeSelectorInstance modName classEntity) selectors
+ mapM (makeSelectorInstance pos modName classEntity)
selectors
return ()
- makeEntity modName (SelectorList (Protocol protoName protocols)
contents)
+ makeEntity modName (pos, SelectorList (Protocol protoName
protocols) contents)
| notHidden protoName
= mfix (\protocolEntity -> do
selectors <- fmap (map fst) $ makeSelectorEntities modName
@@ -211,22 +218,22 @@
eAlternateHaskellNames = [],
eInfo = ProtocolEntity (map
(DelayedProtocolLookup . BS.pack) protocols)
selectors,
- eModule = LocalModule modName
+ eModule = LocalModule modName,
+ eSrcPos = pos
}
) >> return ()
- makeEntity _modName (Typedef (CTStruct _n2 _fields) _name)
+ makeEntity _modName (pos, Typedef (CTStruct _n2 _fields) _name)
= return ()
- makeEntity _modName (Typedef (CTUnion _n2 _fields) _name)
+ makeEntity _modName (pos, Typedef (CTUnion _n2 _fields) _name)
= return ()
- makeEntity modName (Typedef (CTEnum _n2 vals) name)
+ makeEntity modName (pos, Typedef (CTEnum _n2 vals) name)
| notHidden name
- = makeEnum name modName vals
- -- makeAnonymousEnum modName vals -- ### HACK for 10.5:
ignore enum names
- makeEntity modName (CTypeDecl (CTEnum name vals))
+ = makeEnum name pos modName vals
+ makeEntity modName (pos, CTypeDecl (CTEnum name vals))
| null name || notHidden name
- = (if null name {- || True {- ### see above -}-} then
makeAnonymousEnum else makeEnum name) modName vals
+ = (if null name then makeAnonymousEnum else makeEnum name) pos
modName vals
- makeEntity modName (Typedef ct name)
+ makeEntity modName (pos, Typedef ct name)
| notHidden name
= do
newEntity $ Entity {
@@ -234,10 +241,11 @@
eHaskellName = getName name (nameToUppercase name),
eAlternateHaskellNames = [],
eInfo = TypeSynonymEntity (UnconvertedType ct),
- eModule = LocalModule modName
+ eModule = LocalModule modName,
+ eSrcPos = pos
}
return ()
- makeEntity modName (ExternVar ct name)
+ makeEntity modName (pos, ExternVar ct name)
| notHidden name
= do
newEntity $ Entity {
@@ -245,10 +253,11 @@
eHaskellName = getName name (nameToLowercase name),
eAlternateHaskellNames = [],
eInfo = ExternVarEntity (UnconvertedType ct),
- eModule = LocalModule modName
+ eModule = LocalModule modName,
+ eSrcPos = pos
}
return ()
- makeEntity modName (ExternFun sel)
+ makeEntity modName (pos, ExternFun sel)
| notHidden name
= do
newEntity $ Entity {
@@ -256,7 +265,8 @@
eHaskellName = getName name (nameToLowercase name),
eAlternateHaskellNames = [],
eInfo = ExternFunEntity (UnconvertedType
(PlainSelector, sel)),
- eModule = LocalModule modName
+ eModule = LocalModule modName,
+ eSrcPos = pos
}
return ()
where name = selName sel
@@ -278,7 +288,7 @@
= convert Nothing xs
convert _ [] = []
- makeEnum name modName values
+ makeEnum name pos modName values
= case convertEnumEntities values of
(True, values') -> do
newEntity $ Entity {
@@ -286,7 +296,8 @@
eHaskellName = getName name (nameToUppercase
name),
eAlternateHaskellNames = [],
eInfo = EnumEntity True values',
- eModule = LocalModule modName
+ eModule = LocalModule modName,
+ eSrcPos = pos
}
return ()
(False, values') -> do
@@ -295,17 +306,19 @@
eHaskellName = BS.empty,
eAlternateHaskellNames = [],
eInfo = EnumEntity False values',
- eModule = LocalModule modName
+ eModule = LocalModule modName,
+ eSrcPos = pos
}
newEntity $ Entity {
eName = CName $ BS.pack name,
eHaskellName = getName name (nameToUppercase
name),
eAlternateHaskellNames = [],
eInfo = TypeSynonymEntity (UnconvertedType
cTypeInt),
- eModule = LocalModule modName
+ eModule = LocalModule modName,
+ eSrcPos = pos
}
return ()
- makeAnonymousEnum modName values
+ makeAnonymousEnum pos modName values
= do
let (complete, values') = convertEnumEntities values
newEntity $ Entity {
@@ -313,7 +326,8 @@
eHaskellName = BS.empty,
eAlternateHaskellNames = [],
eInfo = EnumEntity complete values',
- eModule = LocalModule modName
+ eModule = LocalModule modName,
+ eSrcPos = pos
}
return ()
@@ -357,7 +371,8 @@
exports
imports2
above,
- eModule = LocalModule $ BS.pack modName
+ eModule = LocalModule $ BS.pack modName,
+ eSrcPos = AutoGeneratedPos
}
newEntity $ Entity {
eName = Anonymous,
@@ -368,7 +383,8 @@
[]
imports1
below,
- eModule = LocalModule $ BS.pack modName
+ eModule = LocalModule $ BS.pack modName,
+ eSrcPos = AutoGeneratedPos
}
return ()
where
Modified: trunk/hoc/InterfaceGenerator2/Entities.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Entities.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Entities.hs Wed Oct 1 15:53:54 2008
@@ -1,4 +1,4 @@
-{-# OPTIONS -fglasgow-exts #-}
+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-}
module Entities where
import Control.Monad.State
@@ -10,6 +10,7 @@
import CTypeToHaskell
import SyntaxTree ( CType, Selector )
import Progress
+import SrcPos( SrcPos )
import Data.ByteString.Char8(ByteString)
import qualified Data.ByteString.Char8 as BS
@@ -77,7 +78,8 @@
eHaskellName :: ByteString,
eAlternateHaskellNames :: [ByteString],
eInfo :: EntityInfo,
- eModule :: Module
+ eModule :: Module,
+ eSrcPos :: SrcPos
}
deriving ( Read, Show, Typeable, Data )
Modified: trunk/hoc/InterfaceGenerator2/HackEnumNames.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/HackEnumNames.hs (original)
+++ trunk/hoc/InterfaceGenerator2/HackEnumNames.hs Wed Oct 1 15:53:54 2008
@@ -9,22 +9,23 @@
hackEnumNames (HeaderInfo name imports decls)
= HeaderInfo name imports (hackEnums1 Just id decls)
where
- hackEnums1 :: (a -> Maybe Declaration) -> (Declaration -> a) ->
[a] -> [a]
+ hackEnums1 :: (a -> Maybe DeclarationAndPos) -> (DeclarationAndPos
-> a) -> [a] -> [a]
hackEnums1 unwrap wrap (x : y : xs)
- | Just (CTypeDecl (CTEnum name1 vals)) <- unwrap x,
- Just (Typedef baseType name2) <- unwrap y,
+ | Just (pos, CTypeDecl (CTEnum name1 vals)) <- unwrap x,
+ Just (_, Typedef baseType name2) <- unwrap y,
null name1 || name1 == name2 || name1 == '_' : name2,
acceptableEnumBaseType baseType
- = wrap (Typedef (CTEnum name1 vals) name2)
+ = wrap (pos, Typedef (CTEnum name1 vals) name2)
: hackEnums1 unwrap wrap xs
hackEnums1 unwrap wrap (x : xs)
- | Just (SelectorList header items) <- unwrap x
- = wrap (SelectorList header (hackEnums1 decl LocalDecl items))
+ | Just (pos, SelectorList header items) <- unwrap x
+ = wrap (pos, SelectorList header (hackEnums1 undecl decl
items))
: hackEnums1 unwrap wrap xs
| otherwise
= x : hackEnums1 unwrap wrap xs
- where decl (LocalDecl d) = Just d
- decl other = Nothing
+ where undecl (pos, LocalDecl d) = Just (pos, d)
+ undecl other = Nothing
+ decl (pos, d) = (pos, LocalDecl d)
hackEnums1 unwrap wrap [] = []
acceptableEnumBaseType (CTSimple name)
Modified: trunk/hoc/InterfaceGenerator2/Headers.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Headers.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Headers.hs Wed Oct 1 15:53:54 2008
@@ -6,12 +6,12 @@
import Parser(header)
import ParserBase(emptyParseEnvironment)
-import SyntaxTree(Declaration)
+import SyntaxTree(ParsedHeader)
import Control.Exception(evaluate)
import Control.Monad(when)
import Data.Char(isAlphaNum, toUpper)
-import Data.List(isPrefixOf,isSuffixOf,partition)
+import Data.List(isPrefixOf,isSuffixOf)
import Data.Maybe(mapMaybe)
import System.Directory(getDirectoryContents)
import System.Info(os)
@@ -27,7 +27,7 @@
import qualified Data.Map as Map
type ModuleName = ByteString
-data HeaderInfo = HeaderInfo ModuleName [ModuleName] [Declaration]
+data HeaderInfo = HeaderInfo ModuleName [ModuleName] ParsedHeader
deriving(Show)
findImports = mapMaybe checkImport . lines
Modified: trunk/hoc/InterfaceGenerator2/Parser.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Parser.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Parser.hs Wed Oct 1 15:53:54 2008
@@ -1,23 +1,21 @@
{-# LANGUAGE TypeSynonymInstances #-}
module Parser( Parser, header, selector ) where
-import Data.Maybe(catMaybes, isJust, fromJust)
-import Data.Char(ord, isUpper, isDigit)
-import Data.Bits(shiftL, (.|.))
-import Control.Monad(guard)
+import Data.Maybe ( isJust, fromJust )
+import Data.Char ( ord, isUpper, isDigit )
+import Data.Bits ( shiftL, (.|.) )
+import Control.Monad ( guard )
import Text.Parsec
import Text.Parsec.Token
-import Text.Parsec.Language(emptyDef)
import Text.Parsec.Expr
import SyntaxTree
-
-import qualified Data.Map as Map
-
+import SrcPos
import ParserBase
+
objcDef = LanguageDef
{ commentStart = "/*"
, commentEnd = "*/"
@@ -40,15 +38,16 @@
singleton x = [x]
-header :: Parser [Declaration]
+header :: Parser ParsedHeader
header = do
optional (whiteSpace objc)
things <- fmap concat $ many $ do
+ pos <- getPosition
-- thing <- try interestingThing <|> uninterestingThing -- lenient
parsing
- thing <- interestingThing -- strict parsing
+ things <- interestingThing -- strict parsing
optional (whiteSpace objc)
- return thing
+ return $ map (\thing -> (parsecPosToSrcPos pos, thing)) things
eof
return things
@@ -397,7 +396,10 @@
return $ Interface class_name super protos
)
instance_variables
- selectors <- fmap concat $ many selectorListItem
+ selectors <- fmap concat $ many $ do
+ pos <- getPosition
+ items <- selectorListItem
+ return $ map (\item -> (parsecPosToSrcPos pos, item)) items
reserved objc "@end"
return [SelectorList what selectors]
where
Modified: trunk/hoc/InterfaceGenerator2/ParserBase.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/ParserBase.hs (original)
+++ trunk/hoc/InterfaceGenerator2/ParserBase.hs Wed Oct 1 15:53:54 2008
@@ -6,7 +6,7 @@
import Control.Monad.Trans( lift )
import Messages
import qualified Text.PrettyPrint.HughesPJ as PP
-
+import SrcPos
type ParseEnvironment = Map.Map String Integer
@@ -30,5 +30,6 @@
parseWarning msg
= do
pos <- getPosition
- lift (message $ PP.text (show pos ++ ": " ++ msg))
+ lift (message $ pprSourcePos (parsecPosToSrcPos pos)
+ PP.<> PP.text (": " ++ msg))
Modified: trunk/hoc/InterfaceGenerator2/ResolveAndZap.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/ResolveAndZap.hs (original)
+++ trunk/hoc/InterfaceGenerator2/ResolveAndZap.hs Wed Oct 1 15:53:54 2008
@@ -4,6 +4,7 @@
import Traversals
import CTypeToHaskell
import Messages
+import SrcPos
import Progress
import Control.Monad.State
@@ -92,7 +93,8 @@
-> return $ Just x
(_, messages)
-> do
- message (text "Skipping"
+ message (pprSourcePos (eSrcPos entity)
+ <> text ": Skipping"
<+> (text.show) entityID
<+> parens (text $ show $ eName
entity)
$+$ nest 4 (vcat messages))
Modified: trunk/hoc/InterfaceGenerator2/ShuffleInstances.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/ShuffleInstances.hs (original)
+++ trunk/hoc/InterfaceGenerator2/ShuffleInstances.hs Wed Oct 1 15:53:54
2008
@@ -39,7 +39,8 @@
eHaskellName = BS.empty,
eAlternateHaskellNames = [],
eInfo = MethodEntity,
- eModule = eModule entity
+ eModule = eModule entity,
+ eSrcPos = eSrcPos entity
}
addProto proto
@@ -48,7 +49,8 @@
eHaskellName = BS.empty,
eAlternateHaskellNames = [],
eInfo = ProtocolAdoptionEntity,
- eModule = eModule entity
+ eModule = eModule entity,
+ eSrcPos = eSrcPos entity
}
_ -> return ()
Added: trunk/hoc/InterfaceGenerator2/SrcPos.hs
==============================================================================
--- (empty file)
+++ trunk/hoc/InterfaceGenerator2/SrcPos.hs Wed Oct 1 15:53:54 2008
@@ -0,0 +1,17 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+module SrcPos where
+
+import Data.Generics
+import Text.PrettyPrint.HughesPJ
+import Text.Parsec( sourceName, sourceLine, sourceColumn )
+
+data SrcPos = SrcPos String Int Int
+ | AutoGeneratedPos
+ deriving ( Read, Show, Eq, Ord, Typeable, Data )
+
+pprSourcePos (SrcPos file line col)
+ = text file <> char ':' <> int line <> char ':' <> int col
+pprSourcePos AutoGeneratedPos
+ = text "<generated>"
+
+parsecPosToSrcPos s = SrcPos (sourceName s) (sourceLine s) (sourceColumn s)
Modified: trunk/hoc/InterfaceGenerator2/SyntaxTree.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/SyntaxTree.hs (original)
+++ trunk/hoc/InterfaceGenerator2/SyntaxTree.hs Wed Oct 1 15:53:54 2008
@@ -1,17 +1,22 @@
-{-# OPTIONS -fglasgow-exts #-}
+{-# LANGUAGE DeriveDataTypeable #-}
module SyntaxTree where
import Data.Generics
+import SrcPos
+
+type ParsedHeader = [ DeclarationAndPos ]
data Declaration =
ForwardClass [String]
| ForwardProtocol [String]
- | SelectorList SelectorListHeader [SelectorListItem]
+ | SelectorList SelectorListHeader [(SrcPos, SelectorListItem)]
| Typedef CType String
| CTypeDecl CType
| ExternVar CType String
| ExternFun Selector
deriving (Show,Eq,Ord)
+
+type DeclarationAndPos = (SrcPos, Declaration)
data SelectorListHeader =
Interface String (Maybe String) [String]
|
