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