Hi, I have a question regarding the GHC API. Given a module, I'm trying to collect * the Name and SrcSpan of all top-level definitions, * the Name and SrcSpan of all (local) uses of these top-level definition * the Name and SrcSpan of all uses of imported definitions. For example, given the file A.hs module B where data Foo = Bar | Baz String main = print $ "Hello, World!" ++ show test test = let x = 2 in x I would like to output: B.Foo - A.hs:3:5-7 B.Bar - A.hs:3:10-12 B.Baz - A.hs:3:10-12 GHC.Base.String - A.hs:3:13-18 B.main - A.hs:5:1-4 System.IO.print - A.hs:5:8-11 GHC.Base.++ - A.hs:5:18-19 etc. (The line/column numbers are made up.) * I do not want to output e.g. 'x' as it's not a top-level identifier (the code I've included below gets this wrong). * I want to output whether the SrcSpan corresponds to a use site or definition site of the Name. For example: 'Foo' is a definition site while 'print' is a use site. I started writing a manual traversal of the RenamedSource AST (as I want qualified names) but I thought I check if I'm going about this right before I spend all the time required to write the traversal for the whole AST. Here's the code I have so far, am I on the right track? ---------- -- | Collects all qualified names that are referred to in a module, -- that are either defineds at the top-level in that module or that -- are imported from some other module. module Main where import Bag import DynFlags ( defaultDynFlags ) import GHC import GHC.Paths ( libdir ) import Outputable import System.Environment -- | Is the 'Name' defined here? data Origin = Local | External type Use = (Name, Origin, SrcSpan) local :: Name -> Use local name = (name, Local, nameSrcSpan name) external :: Name -> SrcSpan -> Use external name loc = (name, External, loc) showName :: (Name, Origin, SrcSpan) -> String showName (name, org, loc) = showSDoc (ppr name) ++ "," ++ showSDoc (ppr loc) ++ "," ++ showOrg org where showOrg Local = "1" showOrg External = "0" main :: IO () main = do [targetFile] <- getArgs res <- defaultErrorHandler defaultDynFlags $ runGhc (Just libdir) $ do dflags <- getSessionDynFlags _ <- setSessionDynFlags dflags target <- guessTarget targetFile Nothing setTargets [target] _ <- load LoadAllTargets modSum <- getModSummary $ mkModuleName "B" p <- parseModule modSum t <- typecheckModule p let Just (r, _, _, _) = tm_renamed_source t return r putStrLn $ showSDoc $ ppr res putStrLn "" putStr $ unlines $ map showName (collectHsGroup res) ------------------------------------------------------------------------ -- AST traversal -- | Collect all external qualified names in the module. collectHsGroup :: HsGroup Name -> [Use] collectHsGroup = collectHsValBindsLR . hs_valds collectHsValBindsLR :: HsValBindsLR Name Name -> [Use] collectHsValBindsLR (ValBindsOut xs _) = concatMap collectHsBindNames . map unLoc . concatMap bagToList . map snd $ xs collectHsValBindsLR (ValBindsIn binds _) = concatMap (collectHsBindNames . unLoc) (bagToList binds) collectHsBindNames :: HsBindLR Name Name -> [Use] collectHsBindNames fb@(FunBind { fun_id = L _ f }) = [local f] ++ collectMatchGroupNames (fun_matches fb) collectHsBindNames _ = [] collectMatchGroupNames :: MatchGroup Name -> [Use] collectMatchGroupNames (MatchGroup matches _) = concat [collectGRHSsNames x | Match _ _ x <- map unLoc matches] collectGRHSsNames :: GRHSs Name -> [Use] collectGRHSsNames (GRHSs xs _) = concatMap (collectGRHSNames . unLoc) xs collectGRHSNames :: GRHS Name -> [Use] collectGRHSNames (GRHS _stmts exprs) = collectHsExprNames exprs -- For less typing collectHsExprNames :: LHsExpr Name -> [Use] collectHsExprNames = collect collect :: LHsExpr Name -> [Use] collect (L loc expr) = go expr where go (HsVar name) | isExternalName name = [external name loc] | otherwise = [] go (HsIPVar _) = [] go (HsOverLit _) = [] go (HsLit _) = [] go (HsLam mg) = collectMatchGroupNames mg go (HsApp e1 e2) = collect e1 ++ collect e2 go (OpApp e1 e2 _ e3) = collect e1 ++ collect e2 ++ collect e3 go (NegApp e1 _) = collect e1 -- ++ collect e2 -- ??? go (HsPar e) = collect e go (SectionL e1 e2) = collect e1 ++ collect e2 go (SectionR e1 e2) = collect e1 ++ collect e2 go (ExplicitTuple xs _) = concat [ collect x | Present x <- xs] go (HsCase e mg) = collect e ++ collectMatchGroupNames mg go (HsIf e1 e2 e3) = collect e1 ++ collect e2 ++ collect e3 go (HsLet binds e) = collectHsLocalBindsLR binds ++ collect e -- go (HsDo (HsStmtContext Name) [LStmt id] (LHsExpr id) PostTcType) = -- go (ExplicitList PostTcType [LHsExpr id]) = -- go (ExplicitPArr PostTcType [LHsExpr id]) = -- go (RecordCon (Located id) PostTcExpr (HsRecordBinds id)) = -- go (RecordUpd (LHsExpr id) (HsRecordBinds id) [DataCon] [PostTcType] [PostTcType]) = -- go (ExprWithTySig (LHsExpr id) (LHsType id)) = -- go (ExprWithTySigOut (LHsExpr id) (LHsType Name)) = -- go (ArithSeq PostTcExpr (ArithSeqInfo id)) = -- go (PArrSeq PostTcExpr (ArithSeqInfo id)) = -- go (HsSCC FastString (LHsExpr id)) = -- go (HsCoreAnn FastString (LHsExpr id)) = -- go (HsBracket (HsBracket id)) = -- go (HsBracketOut (HsBracket Name) [PendingSplice]) = -- go (HsSpliceE (HsSplice id)) = -- go (HsQuasiQuoteE (HsQuasiQuote id)) = -- go (HsProc (LPat id) (LHsCmdTop id)) = -- go (HsArrApp (LHsExpr id) (LHsExpr id) PostTcType HsArrAppType Bool) = -- go (HsArrForm (LHsExpr id) (Maybe Fixity) [LHsCmdTop id]) = -- go (HsTick Int [id] (LHsExpr id)) = -- go (HsBinTick Int Int (LHsExpr id)) = -- go (HsTickPragma (FastString, (Int, Int), (Int, Int)) (LHsExpr id)) = -- go (EWildPat) = -- go (EAsPat (Located id) (LHsExpr id)) = -- go (EViewPat (LHsExpr id) (LHsExpr id)) = -- go (ELazyPat (LHsExpr id)) = -- go (HsType (LHsType id)) = -- go (HsWrap HsWrapper (HsExpr id)) = go _ = [] collectHsLocalBindsLR :: HsLocalBindsLR Name Name -> [Use] collectHsLocalBindsLR (HsValBinds x) = collectHsValBindsLR x collectHsLocalBindsLR _ = []