hiedb 0.6.0.2 → 0.8.0.0
raw patch · 8 files changed
Files
- CHANGELOG.md +7/−0
- hiedb.cabal +6/−4
- src/HieDb/Create.hs +106/−27
- src/HieDb/Query.hs +54/−10
- src/HieDb/Run.hs +12/−6
- src/HieDb/Types.hs +94/−15
- src/HieDb/Utils.hs +11/−11
- test/Main.hs +31/−2
CHANGELOG.md view
@@ -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
hiedb.cabal view
@@ -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
src/HieDb/Create.hs view
@@ -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 ()
src/HieDb/Query.hs view
@@ -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
src/HieDb/Run.hs view
@@ -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
src/HieDb/Types.hs view
@@ -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
src/HieDb/Utils.hs view
@@ -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
test/Main.hs view
@@ -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 <no location info>" , " Details: Just Bool -> Bool {usage}" , "Types:"