session <- newSession JustTypecheck
print "created a session"
flags <- getSessionDynFlags session
- (flags, _) <- parseDynamicFlags flags ghcArgs
+ (pflags, _) <- parseDynamicFlags flags ghcArgs
+ let flags = pflags { hscTarget = HscNothing }
GHC.defaultCleanupHandler flags $ do
flags <- initPackages flags
setSessionDynFlags session flags
- filedata <- mapM (findthings session) filenames
+ setTargets session (map fileTarget filenames)
+ print "set targets"
+ success <- load session LoadAllTargets --- bring module graph up to date
+ filedata <- case success of
+ Failed -> do { putStr "Load failed"; exitWith (ExitFailure 2) }
+ Succeeded -> do
+ print "loaded all targets"
+ graph <- getModuleGraph session
+ print "got modules graph"
+ graphData session graph
if mode == BothTags || mode == CTags
then do
ctagsfile <- openFile "tags" openFileMode
type ThingName = String
--- The position of a token or definition
-data Pos = Pos
- FileName -- file name
- Int -- line number
- Int -- token number
- String -- string that makes up that line
- deriving Show
-
-srcLocToPos :: SrcLoc -> Pos
-srcLocToPos loc =
- Pos (unpackFS $ srcLocFile loc) (srcLocLine loc) (srcLocCol loc) "bogus"
-
-- A definition we have found
-data FoundThing = FoundThing ThingName Pos
- deriving Show
+data FoundThing = FoundThing ModuleName ThingName SrcLoc
-- Data we have obtained from a file
data FileData = FileData FileName [FoundThing]
-data Token = Token String Pos
- deriving Show
-
-
-- stuff for dealing with ctags output format
writectagsfile :: Handle -> [FileData] -> IO ()
getfoundthings (FileData filename things) = things
dumpthing :: FoundThing -> String
-dumpthing (FoundThing name (Pos filename line _ _)) =
+dumpthing (FoundThing modname name loc) =
name ++ "\t" ++ filename ++ "\t" ++ (show $ line + 1)
+ where line = srcLocLine loc
+ filename = unpackFS $ srcLocFile loc
-- stuff for dealing with etags output format
thingslength = length thingsdump
e_dumpthing :: FoundThing -> String
-e_dumpthing (FoundThing name (Pos filename line token fullline)) =
- ---- (concat $ take (token + 1) $ spacedwords fullline)
- name
- ++ "\x7f" ++ (show line) ++ "," ++ (show $ line+1) ++ "\n"
+e_dumpthing (FoundThing modname name loc) =
+ tagline name ++ tagline (moduleNameString modname ++ "." ++ name)
+ where tagline n = n ++ "\x7f" ++ (show line) ++ "," ++ (show $ line+1) ++ "\n"
+ line = srcLocLine loc
+
-- like "words", but keeping the whitespace, and so letting us build
modname :: ModSummary -> ModuleName
modname summary = moduleName $ ms_mod $ summary
-findthings :: Session -> FileName -> IO FileData
-findthings session filename = do
- setTargets session [Target (TargetFile filename Nothing) Nothing]
- print "set targets"
- success <- load session LoadAllTargets --- bring module graph up to date
- case success of
- Failed -> do { print "load failed"; return emptyFileData }
- Succeeded ->
- do print "loaded all targets"
- graph <- getModuleGraph session
- print "got modules graph"
- case modsummary graph filename of
- Nothing -> panic "loaded a module from a file but then could not find its summary"
- Just ms -> do
- mod <- checkModule session (modname ms)
- print "got the module"
- case mod of
- Nothing -> return emptyFileData
- Just m -> case renamedSource m of
- Nothing -> return emptyFileData
- Just s -> return $ fileData filename s
- where emptyFileData = FileData filename []
-
-
-fileData :: FileName -> RenamedSource -> FileData
-fileData filename (group, imports, lie) =
+fileTarget :: FileName -> Target
+fileTarget filename = Target (TargetFile filename Nothing) Nothing
+
+graphData :: Session -> ModuleGraph -> IO [FileData]
+graphData session graph =
+ mapM foundthings graph
+ where foundthings ms =
+ let filename = msHsFilePath ms
+ modname = moduleName $ ms_mod ms
+ in do mod <- checkModule session modname
+ return $ maybe (FileData filename []) id $ do
+ m <- mod
+ s <- renamedSource m
+ return $ fileData filename modname s
+
+fileData :: FileName -> ModuleName -> RenamedSource -> FileData
+fileData filename modname (group, imports, lie) =
-- lie is related to type checking and so is irrelevant
-- imports contains import declarations and no definitions
- FileData filename (boundValues group)
+ FileData filename (boundValues modname group)
-boundValues :: HsGroup Name -> [FoundThing]
-boundValues group =
+boundValues :: ModuleName -> HsGroup Name -> [FoundThing]
+boundValues mod group =
let vals = case hs_valds group of
ValBindsOut nest sigs ->
- [ x | (_rec, binds) <- nest, bind <- bagToList binds, x <- boundThings bind ]
+ [ x | (_rec, binds) <- nest, bind <- bagToList binds,
+ x <- boundThings mod bind ]
tys = concat $ map tyBound (hs_tyclds group)
where tyBound ltcd = case unLoc ltcd of
- ForeignType { tcdLName = n } -> [foundOfLName n]
- TyData { tcdLName = n } -> [foundOfLName n]
- TySynonym { tcdLName = n } -> [foundOfLName n]
- ClassDecl { tcdLName = n } -> [foundOfLName n]
+ ForeignType { tcdLName = n } -> [found n]
+ TyData { tcdLName = tycon, tcdCons = cons } ->
+ dataNames tycon cons
+ TySynonym { tcdLName = n } -> [found n]
+ ClassDecl { tcdLName = n } -> [found n]
fors = concat $ map forBound (hs_fords group)
where forBound lford = case unLoc lford of
- ForeignImport n _ _ -> [foundOfLName n]
+ ForeignImport n _ _ -> [found n]
ForeignExport { } -> []
in vals ++ tys ++ fors
-
-posOfLocated :: Located a -> Pos
-posOfLocated lHs = srcLocToPos $ srcSpanStart $ getLoc lHs
-
-foundOfLName :: Located Name -> FoundThing
-foundOfLName id = FoundThing (getOccString $ unLoc id) (posOfLocated id)
-
-boundThings :: LHsBind Name -> [FoundThing]
-boundThings lbinding =
- let thing = foundOfLName
- in case unLoc lbinding of
- FunBind { fun_id = id } -> [thing id]
- PatBind { pat_lhs = lhs } -> panic "Pattern at top level"
- VarBind { var_id = id } -> [FoundThing (getOccString id) (posOfLocated lbinding)]
- AbsBinds { } -> [] -- nothing interesting in a type abstraction
+ where dataNames tycon cons = found tycon : map conName cons
+ conName td = found $ con_name $ unLoc td
+ found = foundOfLName mod
+
+startOfLocated :: Located a -> SrcLoc
+startOfLocated lHs = srcSpanStart $ getLoc lHs
+
+foundOfLName :: ModuleName -> Located Name -> FoundThing
+foundOfLName mod id = FoundThing mod (getOccString $ unLoc id) (startOfLocated id)
+
+boundThings :: ModuleName -> LHsBind Name -> [FoundThing]
+boundThings modname lbinding =
+ case unLoc lbinding of
+ FunBind { fun_id = id } -> [thing id]
+ PatBind { pat_lhs = lhs } -> patThings lhs []
+ VarBind { var_id = id } -> [FoundThing modname (getOccString id) (startOfLocated lbinding)]
+ AbsBinds { } -> [] -- nothing interesting in a type abstraction
+ where thing = foundOfLName modname
+ patThings lpat tl =
+ let loc = startOfLocated lpat
+ lid id = FoundThing modname (getOccString id) loc
+ in case unLoc lpat of
+ WildPat _ -> tl
+ VarPat name -> lid name : tl
+ VarPatOut name _ -> lid name : tl -- XXX need help here
+ LazyPat p -> patThings p tl
+ AsPat id p -> patThings p (thing id : tl)
+ ParPat p -> patThings p tl
+ BangPat p -> patThings p tl
+ ListPat ps _ -> foldr patThings tl ps
+ TuplePat ps _ _ -> foldr patThings tl ps
+ PArrPat ps _ -> foldr patThings tl ps
+ ConPatIn _ conargs -> conArgs conargs tl
+ ConPatOut _ _ _ _ conargs _ -> conArgs conargs 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
+ DictPat _ _ -> tl
+ conArgs (PrefixCon ps) tl = foldr patThings tl ps
+ conArgs (RecCon pairs) tl = foldr (\(_id, p) tl -> patThings p tl) tl pairs
+ conArgs (InfixCon p1 p2) tl = patThings p1 $ patThings p2 tl
projects / ghc-hetmet.git / blobdiff