diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,12 @@ # Revision history for hiedb +## 0.7.0.0 + +* DB schema change: added new bool field `refs.is_generated` to distinguish between references coming from source code +and those generated by the compiler +* Extended `hie-db ref-graph` cli command by adding possibility to filter by occurrence name / module / unit-id: + `hiedb ref-graph [NAME] [MODULE] [-u|--unit-id UNITID]` + ## 0.6.0.2 * Bump base and ghc version bounds to support GHC 9.12 diff --git a/hiedb.cabal b/hiedb.cabal --- a/hiedb.cabal +++ b/hiedb.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hiedb -version: 0.6.0.2 +version: 0.7.0.0 synopsis: Generates a references DB from .hie files description: Tool and library to index and query a collection of `.hie` files bug-reports: https://github.com/wz1000/HieDb/issues @@ -21,7 +21,7 @@ || ==9.4.8 || ==9.6.7 || ==9.8.4 - || ==9.10.1 + || ==9.10.2 || ==9.12.2 source-repository head @@ -92,3 +92,4 @@ , hspec , process , temporary + , algebraic-graphs diff --git a/src/HieDb/Create.hs b/src/HieDb/Create.hs --- a/src/HieDb/Create.hs +++ b/src/HieDb/Create.hs @@ -4,6 +4,8 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Use camelCase" #-} module HieDb.Create where import Prelude hiding (mod) @@ -37,7 +39,7 @@ import HieDb.Utils sCHEMA_VERSION :: Integer -sCHEMA_VERSION = 8 +sCHEMA_VERSION = 9 dB_VERSION :: Integer dB_VERSION = read (show sCHEMA_VERSION ++ "999" ++ show hieVersion) @@ -117,6 +119,7 @@ \, sc INTEGER NOT NULL \ \, el INTEGER NOT NULL \ \, ec INTEGER NOT NULL \ + \, is_generated BOOLEAN NOT NULL \ \, FOREIGN KEY(hieFile) REFERENCES mods(hieFile) ON UPDATE CASCADE ON DELETE CASCADE DEFERRABLE INITIALLY DEFERRED \ \)" execute_ conn "CREATE INDEX IF NOT EXISTS refs_mod ON refs(hieFile)" @@ -331,27 +334,39 @@ mod = moduleName smod uid = moduleUnit smod smod = hie_module hf - refmap = generateReferencesMap $ getAsts $ hie_asts hf + asts = getAsts $ hie_asts hf + refmapAll = generateReferencesMap asts + refmapSourceOnly = generateReferencesMap $ fmap (dropNodeInfos GeneratedInfo) asts + refmapGeneratedOnly = generateReferencesMap $ fmap (dropNodeInfos SourceInfo) asts (srcFile, isReal) = case sourceFile of RealFile f -> (Just f, True) FakeFile mf -> (mf, False) modrow = HieModuleRow path (ModuleInfo mod uid isBoot srcFile isReal hash) + -- We want to distinguish between references from source (NodeOrigin is SourceInfo) + -- vs. generated by compiler (NodeOrigin is GeneratedInfo). + -- Unfortunately generateReferencesMap throws away the info about NodeOrigin, + -- so we need to use this to preprocess the ASTs from which the references map is generated. + dropNodeInfos :: NodeOrigin -> HieAST a -> HieAST a + dropNodeInfos originToDrop (Node (SourcedNodeInfo sniMap) sp children) = + let sourceOnlyNodeInfo = SourcedNodeInfo $ M.delete originToDrop sniMap + in Node sourceOnlyNodeInfo sp (map (dropNodeInfos originToDrop) children) + execute conn "INSERT INTO mods VALUES (?,?,?,?,?,?,?)" modrow - let AstInfo rows decls imports = genAstInfo path smod refmap + let AstInfo refsSrc declsSrc importsSrc = genAstInfo path smod SourceInfo refmapSourceOnly + AstInfo refsGen declsGen importsGen = genAstInfo path smod GeneratedInfo refmapGeneratedOnly unless (skipRefs skipOptions) $ - executeMany conn "INSERT INTO refs VALUES (?,?,?,?,?,?,?,?)" rows + executeMany conn "INSERT INTO refs VALUES (?,?,?,?,?,?,?,?,?)" (refsSrc <> refsGen) unless (skipDecls skipOptions) $ - executeMany conn "INSERT INTO decls VALUES (?,?,?,?,?,?,?)" decls + executeMany conn "INSERT INTO decls VALUES (?,?,?,?,?,?,?)" (declsSrc <> declsGen) unless (skipImports skipOptions) $ - executeMany conn "INSERT INTO imports VALUES (?,?,?,?,?,?)" imports + executeMany conn "INSERT INTO imports VALUES (?,?,?,?,?,?)" (importsSrc <> importsGen) - let defs = genDefRow path smod refmap + let defs = genDefRow path smod refmapAll unless (skipDefs skipOptions) $ - forM_ defs $ \def -> - execute conn "INSERT INTO defs VALUES (?,?,?,?,?,?)" def + executeMany conn "INSERT INTO defs VALUES (?,?,?,?,?,?)" defs let exports = generateExports path $ hie_exports hf unless (skipExports skipOptions) $ diff --git a/src/HieDb/Query.hs b/src/HieDb/Query.hs --- a/src/HieDb/Query.hs +++ b/src/HieDb/Query.hs @@ -5,7 +5,8 @@ {-# LANGUAGE ScopedTypeVariables #-} module HieDb.Query where -import Algebra.Graph.AdjacencyMap (AdjacencyMap, edges, vertexSet, vertices, overlay) +import Algebra.Graph.AdjacencyMap (AdjacencyMap, edges, induce, vertexSet, vertices, overlay, transpose) +import Algebra.Graph.AdjacencyMap.Algorithm (reachable) import Algebra.Graph.Export.Dot hiding ((:=)) import qualified Algebra.Graph.Export.Dot as G @@ -140,12 +141,7 @@ [":occ" := occ,":mod" := mn, ":unit" := uid] findOneDef :: HieDb -> OccName -> Maybe ModuleName -> Maybe Unit -> IO (Either HieDbErr (Res DefRow)) -findOneDef conn occ mn muid = wrap <$> findDef conn occ mn muid - where - wrap [x] = Right x - wrap [] = Left $ NameNotFound occ mn muid - wrap (x:xs) = Left $ AmbiguousUnitId (defUnit x :| map defUnit xs) - defUnit (_:.i) = i +findOneDef = findOneVia . findDef searchDef :: HieDb -> String -> IO [Res DefRow] searchDef conn cs @@ -154,6 +150,30 @@ \WHERE occ LIKE ? \ \LIMIT 200" (Only $ '_':':':cs++"%") +findDecl :: HieDb -> OccName -> Maybe ModuleName -> Maybe Unit -> IO [Res DeclRow] +findDecl conn occ mn uid + = queryNamed (getConn conn) "SELECT decls.*, mods.mod,mods.unit,mods.is_boot,mods.hs_src,mods.is_real,mods.hash \ + \FROM decls JOIN mods USING (hieFile) \ + \WHERE occ = :occ AND (:mod IS NULL OR mod = :mod) AND (:unit IS NULL OR unit = :unit)" + [":occ" := occ,":mod" := mn, ":unit" := uid] + +findOneDecl :: HieDb -> OccName -> Maybe ModuleName -> Maybe Unit -> IO (Either HieDbErr (Res DeclRow)) +findOneDecl = findOneVia . findDecl + +findOneVia + :: Functor f + => (OccName -> Maybe ModuleName -> Maybe Unit -> f [Res a]) + -> OccName + -> Maybe ModuleName + -> Maybe Unit + -> f (Either HieDbErr (Res a)) +findOneVia f occ mn muid = wrap <$> f occ mn muid + where + wrap [x] = Right x + wrap [] = Left $ NameNotFound occ mn muid + wrap (x:xs) = Left $ AmbiguousUnitId (declUnit x :| map declUnit xs) + declUnit (_:.i) = i + {-| @withTarget db t f@ runs function @f@ with HieFile specified by HieTarget @t@. In case the target is given by ModuleName (and optionally Unit) it is first resolved from HieDb, which can lead to error if given file is not indexed/Module name is ambiguous. @@ -184,8 +204,27 @@ type Vertex = (String, String, String, Int, Int, Int, Int) -declRefs :: HieDb -> IO () -declRefs db = do +-- | Find a @'Res' 'DeclRow'@ by name and return it as a 'Vertex' +lookupVertex :: HieDb -> OccName -> Maybe ModuleName -> Maybe Unit -> IO (Either HieDbErr Vertex) +lookupVertex db occ mm muid = + fmap declRowToVertex <$> findOneDecl db occ mm muid + where + declRowToVertex :: Res DeclRow -> Vertex + declRowToVertex (dr :. mi) = + ( moduleNameString $ modInfoName mi + , declSrc dr + , occNameToField $ declNameOcc dr + , declSLine dr + , declSCol dr + , declELine dr + , declECol dr + ) + + occNameToField :: OccName -> String + occNameToField occ = toNsChar (occNameSpace occ) ++ occNameString occ + +declRefs :: HieDb -> Maybe Vertex -> IO () +declRefs db mv = do graph <- getGraph db writeFile "refs.dot" @@ -197,8 +236,13 @@ ] } ) - graph + (maybe id pruneToCallersOf mv graph) ) + +pruneToCallersOf :: Vertex -> AdjacencyMap Vertex -> AdjacencyMap Vertex +pruneToCallersOf v g = induce (`elem` vs) g + where + vs = reachable (transpose g) v getGraph :: HieDb -> IO (AdjacencyMap Vertex) getGraph (getConn -> conn) = do diff --git a/src/HieDb/Run.hs b/src/HieDb/Run.hs --- a/src/HieDb/Run.hs +++ b/src/HieDb/Run.hs @@ -37,6 +37,7 @@ import Data.Foldable import Data.IORef import Data.List.Extra +import Data.Traversable (for) import Numeric.Natural @@ -101,7 +102,7 @@ | TypesAtPoint HieTarget (Int,Int) (Maybe (Int,Int)) | DefsAtPoint HieTarget (Int,Int) (Maybe (Int,Int)) | InfoAtPoint HieTarget (Int,Int) (Maybe (Int,Int)) - | RefGraph + | RefGraph (Maybe String) (Maybe ModuleName) (Maybe Unit) | Dump FilePath | Reachable [Symbol] | Unreachable [Symbol] @@ -205,7 +206,10 @@ <*> posParser 'S' <*> optional (posParser 'E')) $ progDesc "Print name, module name, unit id for symbol at point/span") - <> command "ref-graph" (info (pure RefGraph) $ progDesc "Generate a reachability graph") + <> command "ref-graph" (info (RefGraph <$> optional (strArgument (metavar "NAME")) + <*> optional moduleNameParser + <*> maybeUnitId) + $ progDesc "Generate a reachability graph") <> command "dump" (info (Dump <$> strArgument (metavar "HIE")) $ progDesc "Dump a HIE AST") <> command "reachable" (info (Reachable <$> some symbolParser) $ progDesc "Find all symbols reachable from the given symbols") @@ -429,7 +433,11 @@ InfoAtPoint target sp mep -> hieFileCommand conn opts target $ \hf -> do mapM_ (uncurry $ printInfo dynFlags) $ pointCommand hf sp mep $ \ast -> (hieTypeToIface . flip recoverFullType (hie_types hf) <$> nodeInfo' ast, nodeSpan ast) - RefGraph -> declRefs conn + RefGraph mname mm muid -> do + mv <- for mname $ \n -> do + let ns = if isCons n then dataName else varName + reportAmbiguousErr opts =<< lookupVertex conn (mkOccName ns n) mm muid + declRefs conn mv Dump path -> do nc <- newIORef =<< makeNc runDbM nc $ dump dynFlags path diff --git a/src/HieDb/Types.hs b/src/HieDb/Types.hs --- a/src/HieDb/Types.hs +++ b/src/HieDb/Types.hs @@ -150,15 +150,17 @@ , refSCol :: Int , refELine :: Int , refECol :: Int + , refIsGenerated :: Bool -- ^ True if the reference to this name is generated by GHC (NodeOrigin is GeneratedInfo) + -- False if it comes from the source code (NodeOrigin is SourceInfo) } instance ToRow RefRow where - toRow (RefRow a b c d e f g h) = toRow ((a,b,c):.(d,e,f):.(g,h)) + toRow (RefRow a b c d e f g h i) = toRow ((a,b,c):.(d,e,f):.(g,h,i)) instance FromRow RefRow where fromRow = RefRow <$> field <*> field <*> field <*> field <*> field <*> field - <*> field <*> field + <*> field <*> field <*> field data DeclRow = DeclRow @@ -178,23 +180,23 @@ fromRow = DeclRow <$> field <*> field <*> field <*> field <*> field <*> field <*> field -data ImportRow - = ImportRow +data ImportRow + = ImportRow { importSrc :: FilePath , importModuleName :: ModuleName - , importSLine :: Int - , importSCol :: Int - , importELine :: Int - , importECol :: Int + , importSLine :: Int + , importSCol :: Int + , importELine :: Int + , importECol :: Int } -instance FromRow ImportRow where - fromRow = - ImportRow - <$> field <*> field <*> field <*> field +instance FromRow ImportRow where + fromRow = + ImportRow + <$> field <*> field <*> field <*> field <*> field <*> field -instance ToRow ImportRow where +instance ToRow ImportRow where toRow (ImportRow a b c d e f) = toRow ((a,b,c,d):.(e,f)) data TypeName = TypeName diff --git a/src/HieDb/Utils.hs b/src/HieDb/Utils.hs --- a/src/HieDb/Utils.hs +++ b/src/HieDb/Utils.hs @@ -179,18 +179,18 @@ instance Monoid AstInfo where mempty = AstInfo [] [] [] -genAstInfo :: FilePath -> Module -> M.Map Identifier [(Span, IdentifierDetails a)] -> AstInfo -genAstInfo path smdl refmap = genRows $ flat $ M.toList refmap +genAstInfo :: FilePath -> Module -> NodeOrigin -> M.Map Identifier [(Span, IdentifierDetails a)] -> AstInfo +genAstInfo path smdl nodeOrigin refmap = genRows $ flat $ M.toList refmap where + isGenerated = nodeOrigin == GeneratedInfo flat = concatMap (\(a,xs) -> map (a,) xs) - genRows = foldMap go - go = mkAstInfo + genRows = foldMap mkAstInfo mkAstInfo x = AstInfo (maybeToList $ goRef x) (maybeToList $ goDec x) (maybeToList $ goImport x) goRef (Right name, (sp,_)) | Just mod <- nameModule_maybe name = Just $ - RefRow path occ (moduleName mod) (moduleUnit mod) sl sc el ec + RefRow path occ (moduleName mod) (moduleUnit mod) sl sc el ec isGenerated where occ = nameOccName name sl = srcSpanStartLine sp diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,13 +1,15 @@ {-# LANGUAGE CPP #-} module Main where +import qualified Algebra.Graph.AdjacencyMap as AdjacencyMap +import Data.Bifunctor (bimap) import GHC.Paths (libdir, ghc) import HieDb (HieDb, HieModuleRow (..), LibDir (..), ModuleInfo (..), withHieDb, withHieFile, addRefsFromLoaded, deleteMissingRealFiles, defaultSkipOptions) -import HieDb.Query (getAllIndexedMods, lookupHieFile, resolveUnitId, lookupHieFileFromSource) +import HieDb.Query (Vertex, getAllIndexedMods, lookupHieFile, resolveUnitId, lookupHieFileFromSource, lookupVertex, getGraph, pruneToCallersOf) import HieDb.Run (Command (..), Options (..), runCommand) import HieDb.Types (HieDbErr (..), SourceFile(..), runDbM) import HieDb.Utils (makeNc) -import HieDb.Compat (stringToUnit, moduleNameString, mkModuleName, getFileHash) +import HieDb.Compat (stringToUnit, moduleNameString, mkModuleName, getFileHash, mkOccName, varName) import System.Directory (findExecutable, getCurrentDirectory, removeDirectoryRecursive) import System.Exit (ExitCode (..), die) import System.FilePath (()) @@ -124,6 +126,29 @@ -- Check that the other modules are still indexed afterMods <- getAllIndexedMods conn originalMods `shouldBe` afterMods + + describe "pruneToCallersOf" $ do + it "prunes the graph to recursive callers of an identifier" $ \conn -> do + result <- lookupVertex conn (mkOccName varName "showInt") Nothing Nothing + + case result of + Left _ -> fail "Failed to lookup vertex for v:showInt" + Right v -> do + g <- getGraph conn + + let + renderFn :: Vertex -> String + renderFn (modName, _, fnName, _, _, _, _) = modName <> "." <> fnName + + callers = + map (bimap renderFn (map renderFn)) + $ AdjacencyMap.adjacencyList + $ pruneToCallersOf v g + + callers `shouldBe` + [ ("Module1.v:function2", ["Sub.Module2.v:showInt"]) + , ("Sub.Module2.v:showInt", []) + ] cliSpec :: Spec cliSpec =