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.8.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,8 +21,9 @@ || ==9.4.8 || ==9.6.7 || ==9.8.4 - || ==9.10.1 + || ==9.10.3 || ==9.12.2 + || ==9.14.1 source-repository head type: git @@ -30,7 +31,7 @@ common common-options default-language: Haskell2010 - build-depends: base >= 4.12 && < 4.22 + build-depends: base >= 4.12 && < 4.23 ghc-options: -Wall -Wcompat -Widentities @@ -61,7 +62,7 @@ HieDb.Dump, HieDb.Html, HieDb.Run - build-depends: ghc >= 8.6 && < 9.13 + build-depends: ghc >= 8.6 && < 9.15 , array , containers , filepath @@ -92,3 +93,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) @@ -15,6 +17,7 @@ import Control.Exception import Control.Monad +import Control.Monad.Cont import Control.Monad.IO.Class import Control.Monad.State.Strict (evalStateT) @@ -37,7 +40,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) @@ -59,26 +62,87 @@ else throwIO $ IncompatibleSchemaVersion dB_VERSION ver +-- | Commmon implementation for the @withHieDb*@ functions that prepared the +-- hiedb file, if it didn't already exist. Also prepares any statements that +-- we'll need to do indexing. +withHieDbImpl :: FilePath -> (HieDb -> IO a) -> IO a +withHieDbImpl fp act = withConnection fp $ \connection -> do + liftIO $ setupHieDb connection + + -- We manually prepare statements instead of using the machinery in + -- sqlite-simple so we can reuse these across `.hie` files more easily. + -- This was benchmarked to be faster: + -- https://github.com/wz1000/HieDb/pull/86 + withPreparedHieDbStatements connection $ \statements -> do + act $ HieDb connection statements + +withPreparedHieDbStatements :: Connection -> (HieDbStatements -> IO a) -> IO a +withPreparedHieDbStatements connection action = do + let prepareInternalTableDeletion = do + deletions + <- traverse (createStatement connection) + [ "DELETE FROM refs WHERE hieFile = ?" + , "DELETE FROM decls WHERE hieFile = ?" + , "DELETE FROM defs WHERE hieFile = ?" + , "DELETE FROM typerefs WHERE hieFile = ?" + , "DELETE FROM mods WHERE hieFile = ?" + , "DELETE FROM exports WHERE hieFile = ?" + ] + pure $ \fp -> mapM_ (`runStatementFor_` fp) deletions + + runContT + ( HieDbStatements + <$> createStatement connection "INSERT INTO mods VALUES (?,?,?,?,?,?,?)" + <*> createStatement connection "INSERT INTO refs VALUES (?,?,?,?,?,?,?,?,?)" + <*> createStatement connection "INSERT INTO decls VALUES (?,?,?,?,?,?,?)" + <*> createStatement connection "INSERT INTO imports VALUES (?,?,?,?,?,?)" + <*> createStatement connection "INSERT INTO defs VALUES (?,?,?,?,?,?)" + <*> createStatement connection "INSERT INTO exports VALUES (?,?,?,?,?,?,?,?)" + <*> createStatement connection "INSERT INTO typerefs VALUES (?,?,?,?,?,?,?)" + <*> createStatement connection "INSERT INTO typenames(name,mod,unit) VALUES (?,?,?)" + <*> createStatement connection "SELECT id FROM typenames WHERE name = ? AND mod = ? AND unit = ?" + <*> prepareInternalTableDeletion + ) + action + {-| Given path to @.hiedb@ file, constructs 'HieDb' and passes it to given function. -} withHieDb :: FilePath -> (HieDb -> IO a) -> IO a -withHieDb fp f = withConnection fp (checkVersion f . HieDb) +withHieDb fp f = withHieDbImpl fp $ \hiedb -> do + checkVersion f hiedb {-| Given GHC LibDir and path to @.hiedb@ file, constructs DynFlags (required for printing info from @.hie@ files) and 'HieDb' and passes them to given function. -} withHieDbAndFlags :: LibDir -> FilePath -> (DynFlags -> HieDb -> IO a) -> IO a -withHieDbAndFlags libdir fp f = do +withHieDbAndFlags libdir fp f = withHieDbImpl fp $ \hiedb -> do dynFlags <- dynFlagsForPrinting libdir - withConnection fp (checkVersion (f dynFlags) . HieDb) + checkVersion (f dynFlags) hiedb {-| Initialize database schema for given 'HieDb'. -} initConn :: HieDb -> IO () -initConn (getConn -> conn) = do +{-# DEPRECATED initConn "Use setupHieDb instead." #-} +initConn = setupHieDb . getConn + +{-| Initialize database schema for given 'HieDb'. +-} +setupHieDb :: Connection -> IO () +setupHieDb conn = do execute_ conn "PRAGMA busy_timeout = 500;" execute_ conn "PRAGMA journal_mode = WAL;" execute_ conn "PRAGMA foreign_keys = ON;" + + -- The default setting for synchronous is 'FULL'. `FULL` will issue fsync's + -- and wait to ensure that every write is done durably. Switching to `NORMAL` + -- moves this to the checkpoints by the WAL (when using a WAL), losing us + -- durability. Practically this means that committed transaction may be rolled + -- back on system failure. This is fine, as the hiedb file will recover by + -- reindexing. See the following. + -- - https://sqlite.org/pragma.html#pragma_synchronous + -- - https://sqlite.org/wal.html + -- - https://github.com/wz1000/HieDb/pull/86 for benchmarks. + execute_ conn "PRAGMA synchronous = NORMAL;" execute_ conn "PRAGMA defer_foreign_keys = ON;" execute_ conn "CREATE TABLE IF NOT EXISTS mods \ @@ -117,6 +181,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)" @@ -185,7 +250,7 @@ corresponding record in DB. -} addArr :: HieDb -> A.Array TypeIndex HieTypeFlat -> IO (A.Array TypeIndex (Maybe Int64)) -addArr (getConn -> conn) arr = do +addArr hiedb arr = do forM arr $ \case HTyVarTy n -> addName n HTyConApp tc _ -> addName (ifaceTyConName tc) @@ -198,8 +263,8 @@ let occ = nameOccName n mod = moduleName m uid = moduleUnit m - execute conn "INSERT INTO typenames(name,mod,unit) VALUES (?,?,?)" (occ,mod,uid) - fmap fromOnly . listToMaybe <$> query conn "SELECT id FROM typenames WHERE name = ? AND mod = ? AND unit = ?" (occ,mod,uid) + runStatementFor_ (insertTypenamesStatement (preparedStatements hiedb)) (occ,mod,uid) + fmap fromOnly <$> runStatementFor (queryTypenamesStatement (preparedStatements hiedb)) (occ,mod,uid) {-| Add references to types from given @.hie@ file to DB. -} addTypeRefs @@ -305,7 +370,7 @@ addRefsFromLoadedInternal db@(getConn -> conn) path sourceFile hash skipOptions hf = liftIO $ withTransaction conn $ do - deleteInternalTables conn path + deleteInternalTablesStatement (preparedStatements db) (Only path) addRefsFromLoaded_unsafe db path sourceFile hash skipOptions hf -- | Like 'addRefsFromLoaded' but without: @@ -314,8 +379,7 @@ -- -- Mostly useful to index a new database from scratch as fast as possible addRefsFromLoaded_unsafe - :: MonadIO m - => HieDb -- ^ HieDb into which we're adding the file + :: HieDb -- ^ HieDb into which we're adding the file -> FilePath -- ^ Path to @.hie@ file -> SourceFile -- ^ Path to .hs file from which @.hie@ file was created -- Also tells us if this is a real source file? @@ -323,39 +387,51 @@ -> Fingerprint -- ^ The hash of the @.hie@ file -> SkipOptions -- ^ Skip indexing certain tables -> HieFile -- ^ Data loaded from the @.hie@ file - -> m () + -> IO () addRefsFromLoaded_unsafe - db@(getConn -> conn) path sourceFile hash skipOptions hf = liftIO $ do + db path sourceFile hash skipOptions hf = do let isBoot = "boot" `isSuffixOf` path 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) - execute conn "INSERT INTO mods VALUES (?,?,?,?,?,?,?)" modrow + -- 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) - let AstInfo rows decls imports = genAstInfo path smod refmap + runStatementFor_ (insertModsStatement (preparedStatements db)) modrow + 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 + mapM_ (runStatementFor_ (insertRefsStatement (preparedStatements db))) (refsSrc <> refsGen) unless (skipDecls skipOptions) $ - executeMany conn "INSERT INTO decls VALUES (?,?,?,?,?,?,?)" decls + mapM_ (runStatementFor_ (insertDeclsStatement (preparedStatements db))) (declsSrc <> declsGen) unless (skipImports skipOptions) $ - executeMany conn "INSERT INTO imports VALUES (?,?,?,?,?,?)" imports + mapM_ (runStatementFor_ (insertImportsStatement (preparedStatements db))) (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 + mapM_ (runStatementFor_ (insertDefsStatement (preparedStatements db))) defs let exports = generateExports path $ hie_exports hf unless (skipExports skipOptions) $ - executeMany conn "INSERT INTO exports VALUES (?,?,?,?,?,?,?,?)" exports + mapM_ (runStatementFor_ (insertExportsStatement (preparedStatements db))) exports unless (skipTypes skipOptions) $ do ixs <- addArr db (hie_types hf) @@ -385,21 +461,21 @@ {-| Delete all occurrences of given @.hie@ file from the database -} deleteFileFromIndex :: HieDb -> FilePath -> IO () -deleteFileFromIndex (getConn -> conn) path = withTransaction conn $ do - deleteInternalTables conn path +deleteFileFromIndex db@(getConn -> conn) path = withTransaction conn $ do + deleteInternalTablesStatement (preparedStatements db) (Only path) {-| Delete all entries associated with modules for which the 'modInfoSrcFile' doesn't exist on the disk. Doesn't delete it if there is no associated 'modInfoSrcFile' -} deleteMissingRealFiles :: HieDb -> IO () -deleteMissingRealFiles (getConn -> conn) = withTransaction conn $ do +deleteMissingRealFiles db@(getConn -> conn) = withTransaction conn $ do missing_file_keys <- fold_ conn "SELECT hieFile,hs_src FROM mods WHERE hs_src IS NOT NULL AND is_real" [] $ \acc (path,src) -> do exists <- doesFileExist src pure $ if exists then acc else path : acc forM_ missing_file_keys $ \path -> do - deleteInternalTables conn path + deleteInternalTablesStatement (preparedStatements db) (Only path) {-| Garbage collect typenames with no references - it is a good idea to call this function after a sequence of database updates (inserts or deletes) @@ -407,6 +483,9 @@ garbageCollectTypeNames :: HieDb -> IO Int garbageCollectTypeNames (getConn -> conn) = do execute_ conn "DELETE FROM typenames WHERE NOT EXISTS ( SELECT 1 FROM typerefs WHERE typerefs.id = typenames.id LIMIT 1 )" + -- Tack on a call to optimize that'll vacuum and update any table statistics + -- that might have changed. See https://sqlite.org/pragma.html#pragma_optimize. + execute_ conn "PRAGMA optimize;" changes conn deleteInternalTables :: Connection -> FilePath -> IO () 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") @@ -273,7 +277,6 @@ when (trace opts) $ setHieTrace conn (Just $ T.hPutStrLn stderr . ("\n****TRACE: "<>)) when (reindex opts) $ do - initConn conn files' <- map hieModuleHieFile <$> getAllIndexedMods conn files <- fmap catMaybes $ forM files' $ \f -> do exists <- doesFileExist f @@ -289,9 +292,8 @@ hPutStrLn stderr $ "Re-indexing " ++ show n ++ " files, deleting " ++ show (n-orig) ++ " files" doIndex conn opts stderr files case cmd of - Init -> initConn conn + Init -> pure () Index dirs -> do - initConn conn files <- concat <$> mapM getHieFilesIn dirs doIndex conn opts stderr files TypeRefs typ mn muid -> do @@ -429,7 +431,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 @@ -7,6 +7,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE TypeApplications #-} module HieDb.Types where import Prelude hiding (mod) @@ -16,9 +17,11 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T +import Control.Exception +import Control.Monad (void) +import Control.Monad.Cont (ContT(..)) import Control.Monad.IO.Class import Control.Monad.Reader -import Control.Exception import Data.List.NonEmpty (NonEmpty(..)) @@ -32,8 +35,82 @@ import HieDb.Compat -newtype HieDb = HieDb { getConn :: Connection } +data HieDb = HieDb + { getConn :: !Connection + , preparedStatements :: HieDbStatements + } +-- | Record of prepared statements that are relevant during the slowest +-- operation, indexing. +-- +-- See benchmarks in https://github.com/wz1000/HieDb/pull/86, where statement +-- preparation results in a ~28% improvement in indexing hie files generated +-- from HLS. +data HieDbStatements = HieDbStatements + { insertModsStatement :: !(StatementFor HieModuleRow) + , insertRefsStatement :: !(StatementFor RefRow) + , insertDeclsStatement :: !(StatementFor DeclRow) + , insertImportsStatement :: !(StatementFor ImportRow) + , insertDefsStatement :: !(StatementFor DefRow) + , insertExportsStatement :: !(StatementFor ExportRow) + , insertTyperefsStatement :: !(StatementFor TypeRef) + , insertTypenamesStatement :: !(StatementFor (OccName, ModuleName, Unit)) + , queryTypenamesStatement :: !(StatementFor (OccName, ModuleName, Unit)) + , deleteInternalTablesStatement :: !(Only FilePath -> IO ()) + } + +-- | A type-safe wrapper connecting the query preparation with the datatype the +-- query is intended for. The type variable 'a' should correspond to the +-- datatype that will be bound to the statement that is wrapped. +newtype StatementFor a = StatementFor Statement + +-- | Equivalent to unit so we can avoid parsing anything when doing insertions. +-- +-- Many of our indexing operations are just simple inserts that don't return +-- results. We can't use the array of @sqlite-simple.execute@ functions as they +-- can't make use of the statements we've prepared. +data NoOutput = NoOutput + +instance FromRow NoOutput where + fromRow = pure NoOutput + +-- | Helper for preparing multiple statements, each of which has to be +-- bracket-wrapped. Done via ContT, so we can use do/applicative notation. +createStatement :: Connection -> Query -> ContT r IO (StatementFor a) +createStatement connection query = fmap StatementFor (ContT (withStatement connection query)) + +-- | Run a statement that was built for an datatype in mind, ensuring that we do +-- indeed pass that datatype. +-- +-- This function is preferably inlined so it'd get specialized with the datatype +-- encoder. +runStatementFor_ :: ToRow a => StatementFor a -> a -> IO () +{-# INLINE runStatementFor_ #-} +runStatementFor_ (StatementFor statement) params = do + withBind statement params $ + -- sqlite-simple doesn't offer the best interface for executing prepared + -- insertions. `nextRow` requires a hint to know what it needs to parse if it + -- encounters content from sqlite. Though this code path isn't hit as our + -- insertions don't return anything, we still need to provide a parsable + -- datatype. Bit of a leaky abstraction, can be cleaned up by using the + -- lower-level `direct-sqlite` instead. + void (nextRow @NoOutput statement) + +-- | Run a statement that was built for an datatype in mind, ensuring that we do +-- indeed pass that datatype. +-- +-- This function is preferably inlined so it'd get specialized with the datatype +-- encoder. +-- +-- NB: While the input variable acts as a witness and is carried around, the +-- output variable is unconstrained. When using this function, double check that +-- the output type is what you expect it to be. +runStatementFor :: (ToRow a, FromRow b) => StatementFor a -> a -> IO (Maybe b) +{-# INLINE runStatementFor #-} +runStatementFor (StatementFor statement) params = do + withBind statement params $ + nextRow statement + data HieDbException = IncompatibleSchemaVersion { expectedVersion :: Integer, gotVersion :: Integer } @@ -150,15 +227,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 +257,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 @@ -35,13 +35,13 @@ import HieDb.Types import HieDb.Compat -import Database.SQLite.Simple import Control.Monad.State.Strict (StateT, get, put) import qualified Data.IntSet as ISet import qualified Data.IntMap.Strict as IMap import Data.IntMap.Strict (IntMap) import Data.IntSet (IntSet) import Control.Monad (guard, unless) +import GHC.Builtin.Utils #if __GLASGOW_HASKELL__ >= 903 import Control.Concurrent.MVar (readMVar) @@ -59,7 +59,7 @@ type TypeIndexing a = StateT (IntMap IntSet) IO a addTypeRef :: HieDb -> FilePath -> A.Array TypeIndex HieTypeFlat -> A.Array TypeIndex (Maybe Int64) -> RealSrcSpan -> TypeIndex -> TypeIndexing () -addTypeRef (getConn -> conn) hf arr ixs sp = go 0 +addTypeRef hiedb hf arr ixs sp = go 0 where sl = srcSpanStartLine sp sc = srcSpanStartCol sp @@ -74,7 +74,7 @@ indexed <- get let isTypeIndexed = ISet.member (fromIntegral occ) (IMap.findWithDefault ISet.empty depth indexed) unless isTypeIndexed $ do - liftIO $ execute conn "INSERT INTO typerefs VALUES (?,?,?,?,?,?,?)" ref + liftIO $ runStatementFor_ (insertTyperefsStatement (preparedStatements hiedb)) ref put $ IMap.alter (\case Nothing -> Just $ ISet.singleton (fromIntegral occ) Just s -> Just $ ISet.insert (fromIntegral occ) s @@ -94,10 +94,10 @@ makeNc :: IO NameCache makeNc = do #if __GLASGOW_HASKELL__ >= 903 - initNameCache 'z' [] + initNameCache 'r' knownKeyNames #else - uniq_supply <- mkSplitUniqSupply 'z' - return $ initNameCache uniq_supply [] + uniq_supply <- mkSplitUniqSupply 'r' + return $ initNameCache uniq_supply knownKeyNames #endif -- | Recursively search for @.hie@ and @.hie-boot@ files in given directory @@ -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 (()) @@ -125,6 +127,29 @@ 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 = -- TODO commands not covered: init, type-refs, ref-graph, dump, reachable, unreachable, html @@ -216,7 +241,11 @@ [ "Span: test/data/Module1.hs:10:8-10" , "Constructors: {(HsVar, HsExpr)}" , "Identifiers:" +#if MIN_VERSION_base(4,22,0) + , "Symbol:v:not:GHC.Internal.Classes:ghc-internal" +#else , "Symbol:v:not:GHC.Classes:ghc-prim" +#endif , "not defined at " , " Details: Just Bool -> Bool {usage}" , "Types:"