Collecting all external names in a module

[Johan Tibell]

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 _ = []
-------------- next part --------------
An HTML attachment was scrubbed...
URL: http://www.haskell.org/pipermail/glasgow-haskell-users/attachments/20100910/2782b5db/attachment.html