diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,8 +1,48 @@ # 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 + +## 0.6.0.1 + +* Bump base and ghc version bounds to support GHC 9.10 + +## 0.6.0.0 -- 2024-02-11 + +* Add index on column `unit` of table `mods` +* Add new table `imports` which indexes import statements +* Add new cli options that allow selectively skipping indexing of some things: + `--skip-refs` Skip refs table when indexing + `--skip-decls` Skip decls table when indexing + `--skip-defs` Skip defs table when indexing + `--skip-exports` Skip exports table when indexing + `--skip-imports` Skip imports table when indexing + `--skip-types` Skip types and typerefs table when indexing + `--skip-typerefs` Skip typerefs table when indexing +* Fix a bug where duplicate entries were inserted into `typerefs` table during indexing +* Fix a bug in `searchDef` query which was mistakenly not including ':' when searching by occurrence names + +## 0.5.0.1 -- 2024-01-12 + +* Fix incorrect Show Symbol instance in 0.5.0.0 + +## 0.5.0.0 -- 2024-01-12 + +* Handle duplicate record fields in GHC 9.8 instead of crashing + ## 0.4.4.0 -- 2023-11-13 + * Add `--src-base-dir` option allowing for src file indexing in `mods` -* 9.8.1 support +* Support GHC 9.8.1 +* Drop support for GHC 8.10 * Add `lookupHieFileFromHash` * Add `lookupPackage` * Add `removeDependencySrcFiles` diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain 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.4.4.0 +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 @@ -10,15 +10,20 @@ maintainer: zubin.duggal@gmail.com copyright: Zubin Duggal category: Development -extra-source-files: - CHANGELOG.md +extra-doc-files: README.md + CHANGELOG.md +extra-source-files: test/data/*.hs test/data/Sub/*.hs -tested-with: GHC ==8.8.1 || ==8.8.2 || ==8.8.3 || ==8.8.4 - || ==8.10.1 || ==8.10.2 || ==8.10.3 || ==8.10.4 - || ==9.0.1 - +tested-with: GHC ==9.0.2 + || ==9.2.8 + || ==9.4.8 + || ==9.6.7 + || ==9.8.4 + || ==9.10.3 + || ==9.12.2 + || ==9.14.1 source-repository head type: git @@ -26,15 +31,17 @@ common common-options default-language: Haskell2010 - build-depends: base >= 4.12 && < 4.20 + build-depends: base >= 4.12 && < 4.23 ghc-options: -Wall - -Wincomplete-uni-patterns - -Wincomplete-record-updates -Wcompat -Widentities - -Wredundant-constraints + -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wpartial-fields - -Wno-unrecognised-pragmas + -Wredundant-constraints + -Wunused-packages + -Wno-name-shadowing + executable hiedb import: common-options hs-source-dirs: exe @@ -55,7 +62,7 @@ HieDb.Dump, HieDb.Html, HieDb.Run - build-depends: ghc >= 8.6 && < 9.9 + build-depends: ghc >= 8.6 && < 9.15 , array , containers , filepath @@ -81,9 +88,9 @@ build-tool-depends: hiedb:hiedb build-depends: directory , filepath - , ghc >= 8.6 , ghc-paths , hiedb , hspec , process , temporary + , algebraic-graphs diff --git a/src/HieDb/Compat.hs b/src/HieDb/Compat.hs --- a/src/HieDb/Compat.hs +++ b/src/HieDb/Compat.hs @@ -25,7 +25,11 @@ , mkVarOccFS , Name , nameSrcSpan +#if __GLASGOW_HASKELL__ >= 903 + , NameCacheUpdater +#else , NameCacheUpdater(..) +#endif , NameCache , nsNames , initNameCache @@ -81,11 +85,13 @@ , IfaceTyCon(..) , field_label , dfs + , fieldNameSpace_maybe + , fieldName + , mkFastStringByteString ) where import Compat.HieTypes -#if __GLASGOW_HASKELL__ >= 900 import GHC.Data.FastString as FS import GHC.Driver.Session import GHC.Iface.Env @@ -111,33 +117,15 @@ #else import GHC.Utils.Outputable (showSDoc, ppr, (<+>), hang, text) #endif -#else -import DynFlags -import FastString -import Fingerprint -import FieldLabel -import Module -import Name -import NameCache -import Outputable (showSDoc, ppr, (<+>), hang, text) -#if __GLASGOW_HASKELL__ < 903 -import IfaceEnv (NameCacheUpdater(..)) -#endif -import IfaceType -import UniqSupply -import SrcLoc -import SysTools -import qualified Avail -#endif -#if __GLASGOW_HASKELL__ >= 900 +import qualified Algebra.Graph.AdjacencyMap as Graph +import qualified Algebra.Graph.AdjacencyMap.Algorithm as Graph + import GHC.Types.SrcLoc import Compat.HieUtils import qualified Data.Map as M import qualified Data.Set as S -import qualified Algebra.Graph.AdjacencyMap as Graph -import qualified Algebra.Graph.AdjacencyMap.Algorithm as Graph -- nodeInfo' :: Ord a => HieAST a -> NodeInfo a @@ -155,22 +143,7 @@ GT -> b : mergeSorted la bs mergeSorted as [] = as mergeSorted [] bs = bs -#else -import qualified FastString as FS -nodeInfo' :: HieAST TypeIndex -> NodeInfo TypeIndex -nodeInfo' = nodeInfo -type Unit = UnitId -unitString :: Unit -> String -unitString = unitIdString -stringToUnit :: String -> Unit -stringToUnit = stringToUnitId -moduleUnit :: Module -> Unit -moduleUnit = moduleUnitId -unhelpfulSpanFS :: FS.FastString -> FS.FastString -unhelpfulSpanFS = id -#endif - #if __GLASGOW_HASKELL__ < 902 type HiePath = FastString #endif @@ -228,4 +201,18 @@ dfs = Graph.dfs #else dfs = flip Graph.dfs +#endif + +fieldNameSpace_maybe :: NameSpace -> Maybe FastString +#if __GLASGOW_HASKELL__ >= 907 +-- This is horrible, we can improve it once +-- https://gitlab.haskell.org/ghc/ghc/-/issues/24244 is addressed +fieldNameSpace_maybe ns = fieldOcc_maybe (mkOccName ns "") +#else +fieldNameSpace_maybe _ = Nothing +#endif + +#if __GLASGOW_HASKELL__ < 907 +fieldName :: FastString -> NameSpace +fieldName _ = varName #endif 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,10 +17,13 @@ import Control.Exception import Control.Monad +import Control.Monad.Cont import Control.Monad.IO.Class +import Control.Monad.State.Strict (evalStateT) import qualified Data.Array as A import qualified Data.Map as M +import qualified Data.IntMap.Strict as IMap import Data.Int import Data.List ( isSuffixOf ) @@ -35,7 +40,7 @@ import HieDb.Utils sCHEMA_VERSION :: Integer -sCHEMA_VERSION = 6 +sCHEMA_VERSION = 9 dB_VERSION :: Integer dB_VERSION = read (show sCHEMA_VERSION ++ "999" ++ show hieVersion) @@ -57,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 \ @@ -91,6 +157,7 @@ \, CONSTRAINT real_has_src CHECK ( (NOT is_real) OR (hs_src IS NOT NULL) ) \ \)" execute_ conn "CREATE INDEX IF NOT EXISTS mod_hash ON mods(hieFile,hash)" + execute_ conn "CREATE INDEX IF NOT EXISTS mod_unit ON mods(unit)" execute_ conn "CREATE TABLE IF NOT EXISTS exports \ \( hieFile TEXT NOT NULL \ @@ -114,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)" @@ -130,6 +198,19 @@ \)" execute_ conn "CREATE INDEX IF NOT EXISTS decls_mod ON decls(hieFile)" + execute_ conn "CREATE TABLE IF NOT EXISTS imports \ + \( hieFile TEXT NOT NULL \ + \, mod TEXT NOT NULL \ + \, sl INTEGER NOT NULL \ + \, sc INTEGER NOT NULL \ + \, el INTEGER NOT NULL \ + \, ec INTEGER NOT NULL \ + \, FOREIGN KEY(hieFile) REFERENCES mods(hieFile) ON UPDATE CASCADE ON DELETE CASCADE DEFERRABLE INITIALLY DEFERRED \ + \)" + execute_ conn "CREATE INDEX IF NOT EXISTS imports_mod ON imports(mod)" + execute_ conn "CREATE INDEX IF NOT EXISTS imports_hiefile ON imports(hieFile)" + + execute_ conn "CREATE TABLE IF NOT EXISTS defs \ \( hieFile TEXT NOT NULL \ \, occ TEXT NOT NULL \ @@ -169,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) @@ -182,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) - Just . fromOnly . head <$> 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 @@ -200,19 +281,47 @@ asts = getAsts $ hie_asts hf addTypesFromAst :: HieAST TypeIndex -> IO () addTypesFromAst ast = do - mapM_ (addTypeRef db path arr ixs (nodeSpan ast)) - $ mapMaybe (\x -> guard (any (not . isOccurrence) (identInfo x)) *> identType x) + flip evalStateT IMap.empty + $ mapM_ (addTypeRef db path arr ixs (nodeSpan ast)) + $ mapMaybe (\x -> guard (not (all isOccurrence (identInfo x))) *> identType x) $ M.elems $ nodeIdentifiers $ nodeInfo' ast mapM_ addTypesFromAst $ nodeChildren ast +-- | Options to skip indexing phases +data SkipOptions = + SkipOptions + { skipRefs :: Bool + , skipDecls :: Bool + , skipDefs :: Bool + , skipExports :: Bool + , skipImports :: Bool + , skipTypes :: Bool + -- ^ Note skip types will also skip type refs since it is dependent + , skipTypeRefs :: Bool + } + deriving Show + +defaultSkipOptions :: SkipOptions +defaultSkipOptions = + SkipOptions + { skipRefs = False + , skipDecls = False + , skipDefs = False + , skipExports = False + , skipImports = False + , skipTypes = False + -- ^ Note skip types will also skip type refs since it is dependent + , skipTypeRefs = False + } + {-| Adds all references from given @.hie@ file to 'HieDb'. The indexing is skipped if the file was not modified since the last time it was indexed. The boolean returned is true if the file was actually indexed -} -addRefsFrom :: (MonadIO m, NameCacheMonad m) => HieDb -> Maybe FilePath -> FilePath -> m Bool -addRefsFrom c@(getConn -> conn) mSrcBaseDir path = do +addRefsFrom :: (MonadIO m, NameCacheMonad m) => HieDb -> Maybe FilePath -> SkipOptions -> FilePath -> m Bool +addRefsFrom c@(getConn -> conn) mSrcBaseDir skipOptions path = do hash <- liftIO $ getFileHash path mods <- liftIO $ query conn "SELECT * FROM mods WHERE hieFile = ? AND hash = ?" (path, hash) case mods of @@ -229,10 +338,10 @@ (\srcBaseDir -> do srcFullPath <- makeAbsolute (srcBaseDir hie_hs_file hieFile) fileExists <- doesFileExist srcFullPath - pure $ if fileExists then RealFile srcFullPath else (FakeFile Nothing) + pure $ if fileExists then RealFile srcFullPath else FakeFile Nothing ) mSrcBaseDir - addRefsFromLoaded c path srcfile hash hieFile + addRefsFromLoadedInternal c path srcfile hash skipOptions hieFile addRefsFromLoaded :: MonadIO m @@ -244,11 +353,25 @@ -> Fingerprint -- ^ The hash of the @.hie@ file -> HieFile -- ^ Data loaded from the @.hie@ file -> m () -addRefsFromLoaded - db@(getConn -> conn) path sourceFile hash hf = +addRefsFromLoaded db path sourceFile hash hf = + addRefsFromLoadedInternal db path sourceFile hash defaultSkipOptions hf + +addRefsFromLoadedInternal + :: MonadIO m + => 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? + -- i.e. does it come from user's project (as opposed to from project's dependency)? + -> Fingerprint -- ^ The hash of the @.hie@ file + -> SkipOptions -- ^ Skip indexing certain tables + -> HieFile -- ^ Data loaded from the @.hie@ file + -> m () +addRefsFromLoadedInternal + db@(getConn -> conn) path sourceFile hash skipOptions hf = liftIO $ withTransaction conn $ do - deleteInternalTables conn path - addRefsFromLoaded_unsafe db path sourceFile hash hf + deleteInternalTablesStatement (preparedStatements db) (Only path) + addRefsFromLoaded_unsafe db path sourceFile hash skipOptions hf -- | Like 'addRefsFromLoaded' but without: -- 1) using a transaction @@ -256,42 +379,64 @@ -- -- 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? -- i.e. does it come from user's project (as opposed to from project's dependency)? -> 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 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 (rows,decls) = genRefsAndDecls path smod refmap - executeMany conn "INSERT INTO refs VALUES (?,?,?,?,?,?,?,?)" rows - executeMany conn "INSERT INTO decls VALUES (?,?,?,?,?,?,?)" decls + runStatementFor_ (insertModsStatement (preparedStatements db)) modrow - let defs = genDefRow path smod refmap - executeMany conn "INSERT INTO defs VALUES (?,?,?,?,?,?)" defs + let AstInfo refsSrc declsSrc importsSrc = genAstInfo path smod SourceInfo refmapSourceOnly + AstInfo refsGen declsGen importsGen = genAstInfo path smod GeneratedInfo refmapGeneratedOnly + unless (skipRefs skipOptions) $ + mapM_ (runStatementFor_ (insertRefsStatement (preparedStatements db))) (refsSrc <> refsGen) + unless (skipDecls skipOptions) $ + mapM_ (runStatementFor_ (insertDeclsStatement (preparedStatements db))) (declsSrc <> declsGen) + unless (skipImports skipOptions) $ + mapM_ (runStatementFor_ (insertImportsStatement (preparedStatements db))) (importsSrc <> importsGen) + + let defs = genDefRow path smod refmapAll + unless (skipDefs skipOptions) $ + mapM_ (runStatementFor_ (insertDefsStatement (preparedStatements db))) defs + let exports = generateExports path $ hie_exports hf - executeMany conn "INSERT INTO exports VALUES (?,?,?,?,?,?,?,?)" exports + unless (skipExports skipOptions) $ + mapM_ (runStatementFor_ (insertExportsStatement (preparedStatements db))) exports - ixs <- addArr db (hie_types hf) - addTypeRefs db path hf ixs + unless (skipTypes skipOptions) $ do + ixs <- addArr db (hie_types hf) + unless (skipTypeRefs skipOptions) $ do + addTypeRefs db path hf ixs {-| Add path to .hs source given path to @.hie@ file which has already been indexed. No action is taken if the corresponding @.hie@ file has not been indexed yet. @@ -316,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) @@ -338,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 @@ -40,7 +41,7 @@ getAllIndexedMods (getConn -> conn) = query_ conn "SELECT * FROM mods" {-| List all module exports -} -getAllIndexedExports :: HieDb -> IO [(ExportRow)] +getAllIndexedExports :: HieDb -> IO [ExportRow] getAllIndexedExports (getConn -> conn) = query_ conn "SELECT * FROM exports" {-| List all exports of the given module -} @@ -140,20 +141,39 @@ [":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 = query (getConn conn) "SELECT defs.*,mods.mod,mods.unit,mods.is_boot,mods.hs_src,mods.is_real,mods.hash \ \FROM defs JOIN mods USING (hieFile) \ \WHERE occ LIKE ? \ - \LIMIT 200" (Only $ '_':cs++"%") + \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,9 +236,14 @@ ] } ) - 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 es <- @@ -224,7 +268,7 @@ one :: Symbol -> IO [Vertex] one s = do - let n = toNsChar (occNameSpace $ symName s) : occNameString (symName s) + let n = symName s m = moduleNameString $ moduleName $ symModule s u = unitString (moduleUnit $ symModule s) query conn "SELECT mods.mod, decls.hieFile, decls.occ, decls.sl, decls.sc, decls.el, decls.ec \ diff --git a/src/HieDb/Run.hs b/src/HieDb/Run.hs --- a/src/HieDb/Run.hs +++ b/src/HieDb/Run.hs @@ -5,6 +5,7 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ApplicativeDo #-} module HieDb.Run where import Prelude hiding (mod) @@ -36,6 +37,7 @@ import Data.Foldable import Data.IORef import Data.List.Extra +import Data.Traversable (for) import Numeric.Natural @@ -80,6 +82,7 @@ , reindex :: Bool , keepMissing :: Bool , srcBaseDir :: Maybe FilePath + , skipIndexingOptions :: SkipOptions } data Command @@ -99,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] @@ -127,10 +130,28 @@ <*> switch (long "reindex" <> short 'r' <> help "Re-index all files in database before running command, deleting those with missing '.hie' files") <*> switch (long "keep-missing" <> help "Keep missing files when re-indexing") <*> optional (strOption (long "src-base-dir" <> help "Provide a base directory to index src files as real files")) + <*> skipFlags where colourFlag = flag' True (long "colour" <> long "color" <> help "Force coloured output") <|> flag' False (long "no-colour" <> long "no-color" <> help "Force uncoloured ouput") <|> pure colr + skipFlags = do + refs <- switch (long "skip-refs" <> help "Skip refs table when indexing") + decls <- switch (long "skip-decls" <> help "Skip decls table when indexing") + defs <- switch (long "skip-defs" <> help "Skip defs table when indexing") + exports <- switch (long "skip-exports" <> help "Skip exports table when indexing") + imports <- switch (long "skip-imports" <> help "Skip imports table when indexing") + types <- switch (long "skip-types" <> help "Skip types and typerefs table when indexing") + typeRefs <- switch (long "skip-typerefs" <> help "Skip typerefs table when indexing") + pure $ SkipOptions + { skipRefs = refs + , skipDecls = decls + , skipDefs = defs + , skipExports = exports + , skipImports = imports + , skipTypes = types + , skipTypeRefs = typeRefs + } cmdParser :: Parser Command cmdParser @@ -185,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") @@ -222,7 +246,7 @@ Just w -> do hPutStr hndl $ replicate w ' ' hPutStr hndl "\r" - pure $ take (w-8) $ msg' + pure $ take (w-8) msg' liftIO $ hPutStr hndl msg x <- act f if x @@ -238,7 +262,7 @@ istart <- offsetTime (length -> done, length -> skipped)<- runDbM nc $ partition id <$> - zipWithM (\f n -> progress' h (length files) n (addRefsFrom conn (srcBaseDir opts)) f) files [0..] + zipWithM (\f n -> progress' h (length files) n (addRefsFrom conn (srcBaseDir opts) (skipIndexingOptions opts)) f) files [0..] indexTime <- istart start <- offsetTime @@ -253,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 @@ -269,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 @@ -372,11 +394,7 @@ reportAmbiguousErr opts (Left $ NoNameAtPoint target sp) forM_ names $ \name -> do case nameSrcSpan name of -#if __GLASGOW_HASKELL__ >= 900 RealSrcSpan dsp _ -> do -#else - RealSrcSpan dsp -> do -#endif unless (quiet opts) $ hPutStrLn stderr $ unwords ["Name", ppName opts (nameOccName name),"at",ppSpan opts sp,"is defined at:"] contents <- case nameModule_maybe name of @@ -413,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 @@ -510,7 +532,7 @@ beforeLines = takeEnd n beforeLines' afterLines = take n afterLines' - (beforeChars,during') = BS.splitAt (sc-1) $ BS.concat $ intersperse "\n" $ duringLines + (beforeChars,during') = BS.splitAt (sc-1) $ BS.concat $ intersperse "\n" duringLines (during,afterChars) = BS.splitAt (BS.length during' - (BS.length (last duringLines) - ec) - 1) during' before = BS.unlines beforeLines <> beforeChars diff --git a/src/HieDb/Types.hs b/src/HieDb/Types.hs --- a/src/HieDb/Types.hs +++ b/src/HieDb/Types.hs @@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE BlockArguments #-} @@ -8,6 +7,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE TypeApplications #-} module HieDb.Types where import Prelude hiding (mod) @@ -15,10 +15,13 @@ import Data.IORef 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 } @@ -90,32 +167,37 @@ instance FromField Fingerprint where fromField fld = readHexFingerprint . T.unpack <$> fromField fld -toNsChar :: NameSpace -> Char +toNsChar :: NameSpace -> String toNsChar ns - | isVarNameSpace ns = 'v' - | isDataConNameSpace ns = 'c' - | isTcClsNameSpace ns = 't' - | isTvNameSpace ns = 'z' + | Just fld_par <- fieldNameSpace_maybe ns + = ('f':unpackFS fld_par) ++ ":" + | isVarNameSpace ns = "v:" + | isDataConNameSpace ns = "c:" + | isTcClsNameSpace ns = "t:" + | isTvNameSpace ns = "z:" | otherwise = error "namespace not recognized" -fromNsChar :: Char -> Maybe NameSpace -fromNsChar 'v' = Just varName -fromNsChar 'c' = Just dataName -fromNsChar 't' = Just tcClsName -fromNsChar 'z' = Just tvName -fromNsChar _ = Nothing +fromNsChar :: T.Text -> Maybe NameSpace +fromNsChar ns + | Just ('f',fieldNameSpace) <- T.uncons ns + = Just (fieldName $ mkFastStringByteString $ T.encodeUtf8 fieldNameSpace) +fromNsChar "v" = Just varName +fromNsChar "c" = Just dataName +fromNsChar "t" = Just tcClsName +fromNsChar "z" = Just tvName +fromNsChar _ = Nothing instance ToField OccName where - toField occ = SQLText $ T.pack $ toNsChar (occNameSpace occ) : occNameString occ + toField occ = SQLText $ T.pack $ toNsChar (occNameSpace occ) ++ occNameString occ instance FromField OccName where fromField fld = case fieldData fld of SQLText t -> - case T.uncons t of - Just (nsChar,occ) - | Just ns <- fromNsChar nsChar -> - return $ mkOccName ns (T.unpack occ) - _ -> returnError ConversionFailed fld "OccName encoding invalid" + case T.break (== ':') t of + (nsText,occ) + | Just ns <- fromNsChar nsText -> + return $ mkOccName ns (T.unpack $ T.tail occ) + _ -> returnError ConversionFailed fld ("OccName encoding invalid: " ++ show t) _ -> returnError Incompatible fld "Expected a SQL string representing an OccName" data HieModuleRow @@ -145,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 @@ -173,6 +257,25 @@ fromRow = DeclRow <$> field <*> field <*> field <*> field <*> field <*> field <*> field +data ImportRow + = ImportRow + { importSrc :: FilePath + , importModuleName :: ModuleName + , importSLine :: Int + , importSCol :: Int + , importELine :: Int + , importECol :: Int + } + +instance FromRow ImportRow where + fromRow = + ImportRow + <$> field <*> field <*> field <*> field + <*> field <*> field + +instance ToRow ImportRow where + toRow (ImportRow a b c d e f) = toRow ((a,b,c,d):.(e,f)) + data TypeName = TypeName { typeName :: OccName , typeMod :: ModuleName @@ -265,22 +368,21 @@ } deriving (Eq, Ord) instance Show Symbol where - show s = toNsChar (occNameSpace $ symName s) - : ':' - : occNameString (symName s) - <> ":" - <> moduleNameString (moduleName $ symModule s) - <> ":" - -- <> unitIdString (moduleUnit $ symModule s) - <> unitString (moduleUnit $ symModule s) + show s = toNsChar (occNameSpace $ symName s) + <> occNameString (symName s) + <> ":" + <> moduleNameString (moduleName $ symModule s) + <> ":" + -- <> unitIdString (moduleUnit $ symModule s) + <> unitString (moduleUnit $ symModule s) instance Read Symbol where readsPrec = const $ R.readP_to_S readSymbol readNameSpace :: R.ReadP NameSpace readNameSpace = do - c <- R.get - maybe R.pfail return (fromNsChar c) + c <- R.many1 R.get + maybe R.pfail return (fromNsChar $ T.pack c) readColon :: R.ReadP () readColon = () <$ R.char ':' diff --git a/src/HieDb/Utils.hs b/src/HieDb/Utils.hs --- a/src/HieDb/Utils.hs +++ b/src/HieDb/Utils.hs @@ -5,7 +5,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE CPP #-} module HieDb.Utils where @@ -19,13 +18,11 @@ import qualified Compat.HieTypes as HieTypes import Compat.HieUtils import qualified Data.Map as M - +import qualified Data.Set as S import System.Directory import System.FilePath -import Control.Arrow ( (&&&) ) -import Data.Bifunctor ( bimap ) import Data.List (find) import Control.Monad.IO.Class import qualified Data.Array as A @@ -38,50 +35,69 @@ import HieDb.Types import HieDb.Compat -import Database.SQLite.Simple -import Control.Concurrent +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 -addTypeRef :: HieDb -> FilePath -> A.Array TypeIndex HieTypeFlat -> A.Array TypeIndex (Maybe Int64) -> RealSrcSpan -> TypeIndex -> IO () -addTypeRef (getConn -> conn) hf arr ixs sp = go 0 +#if __GLASGOW_HASKELL__ >= 903 +import Control.Concurrent.MVar (readMVar) +#endif + +-- Each AST Node can have a lot of repetitive type information, +-- esp. when deriving is involved. +-- This StateT state keeps track of which types in AST we already indexed +-- to avoid having repeated (Depth, Type) inserted under the same RealSrcSpan. +-- +-- This `IntMap IntSet` is morally `Map Depth (Set TypeIndex)` mapping +-- the depth (of a type within tree structure of types - ends up as typerefs.depth) +-- to a list of type IDs (identifiers of types assigned as id within typenames table) +-- that we already indexed. +type TypeIndexing a = StateT (IntMap IntSet) IO a + +addTypeRef :: HieDb -> FilePath -> A.Array TypeIndex HieTypeFlat -> A.Array TypeIndex (Maybe Int64) -> RealSrcSpan -> TypeIndex -> TypeIndexing () +addTypeRef hiedb hf arr ixs sp = go 0 where sl = srcSpanStartLine sp sc = srcSpanStartCol sp el = srcSpanEndLine sp ec = srcSpanEndCol sp - go :: TypeIndex -> Int -> IO () - go d i = do + go :: Int -> TypeIndex -> TypeIndexing () + go depth i = do case ixs A.! i of Nothing -> pure () Just occ -> do - let ref = TypeRef occ hf d sl sc el ec - execute conn "INSERT INTO typerefs VALUES (?,?,?,?,?,?,?)" ref - let next = go (d+1) + let ref = TypeRef occ hf depth sl sc el ec + indexed <- get + let isTypeIndexed = ISet.member (fromIntegral occ) (IMap.findWithDefault ISet.empty depth indexed) + unless isTypeIndexed $ do + liftIO $ runStatementFor_ (insertTyperefsStatement (preparedStatements hiedb)) ref + put $ IMap.alter (\case + Nothing -> Just $ ISet.singleton (fromIntegral occ) + Just s -> Just $ ISet.insert (fromIntegral occ) s + ) depth indexed + let next = go (depth + 1) case arr A.! i of HTyVarTy _ -> pure () -#if __GLASGOW_HASKELL__ >= 808 HAppTy x (HieArgs xs) -> mapM_ next (x:map snd xs) -#else - HAppTy x y -> mapM_ next [x,y] -#endif HTyConApp _ (HieArgs xs) -> mapM_ (next . snd) xs HForAllTy ((_ , a),_) b -> mapM_ next [a,b] -#if __GLASGOW_HASKELL__ >= 900 HFunTy a b c -> mapM_ next [a,b,c] -#else - HFunTy a b -> mapM_ next [a,b] -#endif HQualTy a b -> mapM_ next [a,b] HLitTy _ -> pure () - HCastTy a -> go d a + HCastTy a -> go depth a HCoercionTy -> pure () 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 @@ -122,11 +138,7 @@ #endif return $ case lookupOrigNameCache nsns mdl occ of Just name -> case nameSrcSpan name of -#if __GLASGOW_HASKELL__ >= 900 RealSrcSpan sp _ -> Right (sp, mdl) -#else - RealSrcSpan sp -> Right (sp, mdl) -#endif UnhelpfulSpan msg -> Left $ NameUnhelpfulSpan name (unpackFS $ unhelpfulSpanFS msg) Nothing -> Left $ NameNotFound occ (Just $ moduleName mdl) (Just $ moduleUnit mdl) @@ -143,18 +155,10 @@ dynFlagsForPrinting :: LibDir -> IO DynFlags dynFlagsForPrinting (LibDir libdir) = do - systemSettings <- initSysTools -#if __GLASGOW_HASKELL__ >= 808 - libdir -#else - (Just libdir) -#endif -#if __GLASGOW_HASKELL__ >= 905 + systemSettings <- initSysTools libdir return $ defaultDynFlags systemSettings -#elif __GLASGOW_HASKELL__ >= 810 - return $ defaultDynFlags systemSettings $ LlvmConfig [] [] -#else - return $ defaultDynFlags systemSettings ([], []) +#if __GLASGOW_HASKELL__ < 905 + (LlvmConfig [] []) #endif isCons :: String -> Bool @@ -162,16 +166,31 @@ isCons (x:_) | isUpper x = True isCons _ = False -genRefsAndDecls :: FilePath -> Module -> M.Map Identifier [(Span, IdentifierDetails a)] -> ([RefRow],[DeclRow]) -genRefsAndDecls path smdl refmap = genRows $ flat $ M.toList refmap +data AstInfo = + AstInfo + { astInfoRefs :: [RefRow] + , astInfoDecls :: [DeclRow] + , astInfoImports :: [ImportRow] + } + +instance Semigroup AstInfo where + AstInfo r1 d1 i1 <> AstInfo r2 d2 i2 = AstInfo (r1 <> r2) (d1 <> d2) (i1 <> i2) + +instance Monoid AstInfo where + mempty = AstInfo [] [] [] + +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 = bimap maybeToList maybeToList . (goRef &&& goDec) + 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 @@ -180,6 +199,16 @@ ec = srcSpanEndCol sp goRef _ = Nothing + goImport (Left modName, (sp, IdentifierDetails _ contextInfos)) = do + _ <- guard $ not $ S.disjoint contextInfos $ S.fromList [IEThing Import, IEThing ImportAs, IEThing ImportHiding] + let + sl = srcSpanStartLine sp + sc = srcSpanStartCol sp + el = srcSpanEndLine sp + ec = srcSpanEndCol sp + Just $ ImportRow path modName sl sc el ec + goImport _ = Nothing + goDec (Right name,(_,dets)) | Just mod <- nameModule_maybe name , mod == smdl @@ -211,11 +240,7 @@ where genRows = mapMaybe go getSpan name dets -#if __GLASGOW_HASKELL__ >= 900 | RealSrcSpan sp _ <- nameSrcSpan name = Just sp -#else - | RealSrcSpan sp <- nameSrcSpan name = Just sp -#endif | otherwise = do (sp, _dets) <- find defSpan dets pure 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) -import HieDb.Query (getAllIndexedMods, lookupHieFile, resolveUnitId, lookupHieFileFromSource) +import HieDb (HieDb, HieModuleRow (..), LibDir (..), ModuleInfo (..), withHieDb, withHieFile, addRefsFromLoaded, deleteMissingRealFiles, defaultSkipOptions) +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 (()) @@ -88,6 +90,7 @@ -- Index a new real file, and delete it let contents = unlines [ "module Test123 where" + , "import Prelude" , "foobarbaz :: Int" , "foobarbaz = 1" ] @@ -124,7 +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 @@ -143,7 +168,7 @@ ] (exitCode, actualStdin, _actualStdErr) <- runHieDbCli ["ls"] exitCode `shouldBe` ExitSuccess - (sort $ lines actualStdin) `shouldBe` (sort expectedOutput) + sort (lines actualStdin) `shouldBe` sort expectedOutput describe "name-refs" $ it "lists all references of given function" $ do @@ -167,8 +192,7 @@ it "Prints types of symbol under cursor" $ runHieDbCli ["point-types", "Module1", "10", "10" ] `succeedsWithStdin` unlines - [ "Int -> Bool" {- types of `even` function under cursor -} - , "forall a. Integral a => a -> Bool" + [ "Bool -> Bool" {- type of `not` function under cursor -} ] it "Fails for symbols that don't have type associated" $ do (exitCode, actualStdout, actualStderr) <- runHieDbCli ["point-types", "Module1", "8", "21"] @@ -180,7 +204,7 @@ it "outputs the location of symbol when definition site can be found is indexed" $ runHieDbCli ["point-defs", "Module1", "13", "29"] `succeedsWithStdin` unlines - [ "Sub.Module2:7:1-7:8" + [ "Sub.Module2:8:1-8:8" ] it "Fails with informative error message when there's no symbol at given point" $ do (exitCode, actualStdout, actualStderr) <- runHieDbCli ["point-defs", "Module1", "13", "13"] @@ -192,60 +216,52 @@ (exitCode, actualStdout, actualStderr) <- runHieDbCli ["point-defs", "Module1", "13", "24"] actualStdout `shouldBe` "" exitCode `shouldBe` ExitFailure 1 - actualStderr `shouldBe` "Couldn't find name: $ from module GHC.Base(base)\n" + actualStderr `shouldBe` +#if MIN_VERSION_base(4,20,0) + "Couldn't find name: $ from module GHC.Internal.Base(ghc-internal)\n" +#else + "Couldn't find name: $ from module GHC.Base(base)\n" +#endif describe "point-info" $ do it "gives information about symbol at specified location" $ - runHieDbCli ["point-info", "Sub.Module2", "10", "10"] + runHieDbCli ["point-info", "Sub.Module2", "11", "11"] `succeedsWithStdin` unlines - [ "Span: test/data/Sub/Module2.hs:10:7-23" + [ "Span: test/data/Sub/Module2.hs:11:7-23" , "Constructors: {(ConDeclH98, ConDecl)}" , "Identifiers:" , "Symbol:c:Data1Constructor1:Sub.Module2:main" - , "Data1Constructor1 defined at test/data/Sub/Module2.hs:10:7-23" -#if __GLASGOW_HASKELL__ >= 900 - , " Details: Nothing {declaration of constructor bound at: test/data/Sub/Module2.hs:10:7-23}" -#else - , " IdentifierDetails Nothing {Decl ConDec (Just SrcSpanOneLine \"test/data/Sub/Module2.hs\" 10 7 24)}" -#endif + , "Data1Constructor1 defined at test/data/Sub/Module2.hs:11:7-23" + , " Details: Nothing {declaration of constructor bound at: test/data/Sub/Module2.hs:11:7-23}" , "Types:\n" ] it "correctly prints type signatures" $ runHieDbCli ["point-info", "Module1", "10", "10"] `succeedsWithStdin` unlines - [ "Span: test/data/Module1.hs:10:8-11" -#if __GLASGOW_HASKELL__ >= 902 - , "Constructors: {(XExpr, HsExpr), (HsVar, HsExpr)}" -#elif __GLASGOW_HASKELL__ >= 900 - , "Constructors: {(HsVar, HsExpr), (XExpr, HsExpr)}" -#else - , "Constructors: {(HsVar, HsExpr), (HsWrap, HsExpr)}" -#endif + [ "Span: test/data/Module1.hs:10:8-10" + , "Constructors: {(HsVar, HsExpr)}" , "Identifiers:" - , "Symbol:v:even:GHC.Real:base" - , "even defined at " -#if __GLASGOW_HASKELL__ >= 900 - , " Details: Just forall a. Integral a => a -> Bool {usage}" - , "$dIntegral defined at " - , " Details: Just Integral Int {usage of evidence variable}" +#if MIN_VERSION_base(4,22,0) + , "Symbol:v:not:GHC.Internal.Classes:ghc-internal" #else - , " IdentifierDetails Just forall a. Integral a => a -> Bool {Use}" + , "Symbol:v:not:GHC.Classes:ghc-prim" #endif + , "not defined at " + , " Details: Just Bool -> Bool {usage}" , "Types:" - , "Int -> Bool" - , "forall a. Integral a => a -> Bool" + , "Bool -> Bool" , "" ] describe "name-def" $ it "lookup definition of name" $ runHieDbCli ["name-def", "showInt"] - `succeedsWithStdin` "Sub.Module2:7:1-7:8\n" + `succeedsWithStdin` "Sub.Module2:8:1-8:8\n" describe "type-def" $ it "lookup definition of type" $ runHieDbCli ["type-def", "Data1"] - `succeedsWithStdin` "Sub.Module2:9:1-11:28\n" + `succeedsWithStdin` "Sub.Module2:10:1-12:28\n" describe "cat" $ describe "dumps module source stored in .hie file" $ do @@ -371,4 +387,5 @@ , reindex = False , keepMissing = False , srcBaseDir = Nothing + , skipIndexingOptions = defaultSkipOptions } diff --git a/test/data/Module1.hs b/test/data/Module1.hs --- a/test/data/Module1.hs +++ b/test/data/Module1.hs @@ -5,9 +5,9 @@ import Sub.Module2 (showInt) -function1 :: Int -> String -function1 i = - if even i then "It's even" else "It's odd" +function1 :: Bool -> String +function1 b = + if not b then "It's false" else "It's true" function2 :: Int -> IO () function2 i = putStrLn $ showInt i diff --git a/test/data/Sub/Module2.hs b/test/data/Sub/Module2.hs --- a/test/data/Sub/Module2.hs +++ b/test/data/Sub/Module2.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DuplicateRecordFields #-} module Sub.Module2 ( showInt , Data1(..) @@ -9,3 +10,9 @@ data Data1 = Data1Constructor1 | Data1Constructor2 Int + +data Data2 + = Data2C { foo :: Int, bar :: String } + +data Data3 + = Data3C { foo :: Int, baz :: Bool }