Johan GHC already collects all RdrNames for imported things, for use when reporting unused imports. But it doesn't collect the SrcSpan of the occurrences, nor does it collect occurrences of locally-bound things. I suggest you write a general traversal looking like data Gather var res = Gather { g_empty :: res , g_union :: res -> res -> res , g_occ :: Located var -> res , g_del :: Located var -> res -> res } getExpr :: Gather v res -> HsExpr v -> res .. and similarly for each other data type... You could even use generic programming to do it (all the Hs things are in class Data I think). The GHC could use this function instead of its present mechanism for the unused-import thing, and you could use it too. Simon From: glasgow-haskell-users-bounces@haskell.org [mailto:glasgow-haskell-users-bounces@haskell.org] On Behalf Of Johan Tibell Sent: 10 September 2010 15:35 To: glasgow-haskell-users Subject: Collecting all external names in a module 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 _ = []