Add command to get transitive callsites

wz1000 · Jun 10, 2024 · 81701a2 · 81701a2
1 parent cf132f1
commit 81701a2
Show file tree

Hide file tree

Showing 2 changed files with 32 additions and 0 deletions.
diff --git a/src/HieDb/Query.hs b/src/HieDb/Query.hs
@@ -53,6 +53,28 @@ findExporters :: HieDb -> OccName -> ModuleName -> Unit -> IO [ModuleName]
 findExporters (getConn -> conn) occ mn unit =
   query conn "SELECT mods.mod FROM exports JOIN mods USING (hieFile) WHERE occ = ? AND mod = ? AND unit = ?" (occ, mn, unit)
 
+-- | Recursively find all the places where this symbol is (transitively) called
+findRecursiveCalls :: HieDb -> OccName -> Maybe ModuleName -> Maybe Unit -> IO [(OccName,Maybe ModuleName,Maybe Unit,Maybe OccName, Maybe ModuleName, (Maybe Int, Maybe Int, Maybe Int, Maybe Int))]
+findRecursiveCalls (getConn -> conn) occ mn unit =
+  fmap (\(x1,x2,x3,x4,x5,x6,x7,x8,x9) -> (x1,x2,x3,x4,x5,(x6,x7,x8,x9))) <$>
+  queryNamed conn
+    "WITH RECURSIVE \
+    \  calls(occ,mod,unit,cocc,cmod,sl,sc,el,ec) AS ( \
+    \    VALUES (:occ,:mod,:unit,NULL,NULL,NULL,NULL,NULL,NULL) \
+    \    UNION \
+    \    SELECT decls.occ, mods.mod, mods.unit, refs.occ, refs.mod, refs.sl, refs.sc, refs.el, refs.ec \
+    \    FROM calls \
+    \    JOIN refs  ON refs.occ = calls.occ AND (calls.mod  IS NULL OR refs.mod  = calls.mod) \
+                                           \AND (calls.unit IS NULL OR refs.unit = calls.unit)\
+    \    JOIN decls ON decls.hieFile = refs.hieFile AND ((refs.sl = decls.sl AND refs.sc >  decls.sc) OR (refs.sl > decls.sl)) \
+                                                   \AND ((refs.el = decls.el AND refs.ec <= decls.ec) OR (refs.el < decls.el)) \
+    \    JOIN mods ON mods.hieFile = decls.hieFile \
+    \    WHERE \
+    \    (decls.occ != calls.occ OR (calls.mod IS NOT NULL AND mods.mod != calls.mod) OR (calls.unit IS NOT NULL or mods.unit != calls.unit)) \
+    \  ) \
+    \SELECT * FROM calls;"
+    [":occ" := occ, ":mod" := mn, ":unit" := unit]
+
 {-| Lookup Unit associated with given ModuleName.
 HieDbErr is returned if no module with given name has been indexed
 or if ModuleName is ambiguous (i.e. there are multiple packages containing module with given name)

diff --git a/src/HieDb/Run.hs b/src/HieDb/Run.hs
@@ -90,6 +90,7 @@ data Command
   | NameRefs String (Maybe ModuleName) (Maybe Unit)
   | TypeRefs String (Maybe ModuleName) (Maybe Unit)
   | NameDef  String (Maybe ModuleName) (Maybe Unit)
+  | NameCalls String (Maybe ModuleName) (Maybe Unit)
   | TypeDef  String (Maybe ModuleName) (Maybe Unit)
   | Cat HieTarget
   | Ls
@@ -169,6 +170,10 @@ cmdParser
                                        <*> optional moduleNameParser
                                        <*> maybeUnitId)
                          $ progDesc "Lookup definition of value MODULE.NAME")
+  <> command "name-calls" (info (NameCalls <$> strArgument (metavar "NAME")
+                                           <*> optional moduleNameParser
+                                           <*> maybeUnitId)
+                         $ progDesc "Recursively find all callsites of MODULE.NAME")
   <> command "type-def" (info (TypeDef <$> strArgument (metavar "NAME")
                                        <*> optional moduleNameParser
                                        <*> maybeUnitId)
@@ -309,6 +314,11 @@ runCommand libdir opts cmd = withHieDbAndFlags libdir (database opts) $ \dynFlag
       (row:.inf) <- reportAmbiguousErr opts =<< findOneDef conn occ mn muid
       let mdl = mkModule (modInfoUnit inf) (modInfoName inf)
       reportRefSpans opts [(mdl, (defSLine row, defSCol row), (defELine row, defECol row),Just $ Left (defSrc row))]
+    NameCalls nm mn muid -> do
+      let ns = if isCons nm then dataName else varName
+      let occ = mkOccName ns nm
+      refs <- findRecursiveCalls conn occ mn muid
+      mapM_ (putStrLn . showSDoc dynFlags . ppr) refs
     TypeDef nm mn muid -> do
       let occ = mkOccName tcClsName nm
       (row:.inf) <- reportAmbiguousErr opts =<< findOneDef conn occ mn muid