projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Follow Src{Loc,Span} changes in other parts of the tree
[ghc-hetmet.git]
/
utils
/
ghctags
/
Main.hs
diff --git
a/utils/ghctags/Main.hs
b/utils/ghctags/Main.hs
index
118bcac
..
4ba8157
100644
(file)
--- a/
utils/ghctags/Main.hs
+++ b/
utils/ghctags/Main.hs
@@
-10,11
+10,13
@@
import DriverPhases ( isHaskellSrcFilename )
import HscTypes ( msHsFilePath )
import Name ( getOccString )
--import ErrUtils ( printBagOfErrors )
import HscTypes ( msHsFilePath )
import Name ( getOccString )
--import ErrUtils ( printBagOfErrors )
+import Panic ( panic )
import DynFlags ( defaultDynFlags )
import Bag
import Exception
import FastString
import MonadUtils ( liftIO )
import DynFlags ( defaultDynFlags )
import Bag
import Exception
import FastString
import MonadUtils ( liftIO )
+import SrcLoc
-- Every GHC comes with Cabal anyways, so this is not a bad new dependency
import Distribution.Simple.GHC ( ghcOptions )
-- Every GHC comes with Cabal anyways, so this is not a bad new dependency
import Distribution.Simple.GHC ( ghcOptions )
@@
-48,7
+50,7
@@
type FileName = String
type ThingName = String -- name of a defined entity in a Haskell program
-- A definition we have found (we know its containing module, name, and location)
type ThingName = String -- name of a defined entity in a Haskell program
-- A definition we have found (we know its containing module, name, and location)
-data FoundThing = FoundThing ModuleName ThingName SrcLoc
+data FoundThing = FoundThing ModuleName ThingName RealSrcLoc
-- Data we have obtained from a file (list of things we found)
data FileData = FileData FileName [FoundThing] (Map Int String)
-- Data we have obtained from a file (list of things we found)
data FileData = FileData FileName [FoundThing] (Map Int String)
@@
-100,7
+102,7
@@
main = do
then Just `liftM` openFile "TAGS" openFileMode
else return Nothing
then Just `liftM` openFile "TAGS" openFileMode
else return Nothing
- GHC.defaultErrorHandler defaultDynFlags $
+ GHC.defaultErrorHandler (defaultDynFlags (panic "No settings")) $
runGhc (Just ghc_topdir) $ do
--liftIO $ print "starting up session"
dflags <- getSessionDynFlags
runGhc (Just ghc_topdir) $ do
--liftIO $ print "starting up session"
dflags <- getSessionDynFlags
@@
-251,7
+253,7
@@
boundValues mod group =
, bind <- bagToList binds
, x <- boundThings mod bind ]
_other -> error "boundValues"
, bind <- bagToList binds
, x <- boundThings mod bind ]
_other -> error "boundValues"
- tys = [ n | ns <- map hsTyClDeclBinders (hs_tyclds group)
+ tys = [ n | ns <- map hsTyClDeclBinders (concat (hs_tyclds group))
, n <- map found ns ]
fors = concat $ map forBound (hs_fords group)
where forBound lford = case unLoc lford of
, n <- map found ns ]
fors = concat $ map forBound (hs_fords group)
where forBound lford = case unLoc lford of
@@
-260,8
+262,10
@@
boundValues mod group =
in vals ++ tys ++ fors
where found = foundOfLName mod
in vals ++ tys ++ fors
where found = foundOfLName mod
-startOfLocated :: Located a -> SrcLoc
-startOfLocated lHs = srcSpanStart $ getLoc lHs
+startOfLocated :: Located a -> RealSrcLoc
+startOfLocated lHs = case getLoc lHs of
+ RealSrcSpan l -> realSrcSpanStart l
+ UnhelpfulSpan _ -> panic "startOfLocated UnhelpfulSpan"
foundOfLName :: ModuleName -> Located Name -> FoundThing
foundOfLName mod id = FoundThing mod (getOccString $ unLoc id) (startOfLocated id)
foundOfLName :: ModuleName -> Located Name -> FoundThing
foundOfLName mod id = FoundThing mod (getOccString $ unLoc id) (startOfLocated id)
@@
-292,7
+296,6
@@
boundThings modname lbinding =
LitPat _ -> tl
NPat _ _ _ -> tl -- form of literal pattern?
NPlusKPat id _ _ _ -> thing id : tl
LitPat _ -> tl
NPat _ _ _ -> tl -- form of literal pattern?
NPlusKPat id _ _ _ -> thing id : tl
- TypePat _ -> tl -- XXX need help here
SigPatIn p _ -> patThings p tl
SigPatOut p _ -> patThings p tl
_ -> error "boundThings"
SigPatIn p _ -> patThings p tl
SigPatOut p _ -> patThings p tl
_ -> error "boundThings"