RE: Collecting all external names in a module

17 Sep 2010

      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 _ = []

RE: Collecting all external names in a module

Simon Peyton-Jones