diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,12 @@ # Revision history for hiedb +## 0.4.4.0 -- 2023-11-13 +* Add `--src-base-dir` option allowing for src file indexing in `mods` +* 9.8.1 support +* Add `lookupHieFileFromHash` +* Add `lookupPackage` +* Add `removeDependencySrcFiles` + ## 0.4.3.0 -- 2023-03-13 * Support GHC 9.6 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.3.0 +version: 0.4.4.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 @@ -26,7 +26,7 @@ common common-options default-language: Haskell2010 - build-depends: base >= 4.12 && < 4.18 + build-depends: base >= 4.12 && < 4.20 ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates @@ -55,7 +55,7 @@ HieDb.Dump, HieDb.Html, HieDb.Run - build-depends: ghc >= 8.6 + build-depends: ghc >= 8.6 && < 9.9 , array , containers , filepath @@ -65,7 +65,7 @@ , hie-compat ^>= 0.3 , text , bytestring - , algebraic-graphs >= 0.3 && < 0.7 + , algebraic-graphs >= 0.3 , lucid , optparse-applicative , extra diff --git a/src/HieDb/Compat.hs b/src/HieDb/Compat.hs --- a/src/HieDb/Compat.hs +++ b/src/HieDb/Compat.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE CPP, PatternSynonyms, ViewPatterns #-} +{-# LANGUAGE CPP, PatternSynonyms, ViewPatterns, TupleSections #-} module HieDb.Compat ( nodeInfo' , Unit @@ -80,6 +80,7 @@ , IfaceType , IfaceTyCon(..) , field_label + , dfs ) where import Compat.HieTypes @@ -135,6 +136,8 @@ 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 @@ -182,7 +185,9 @@ {-# COMPLETE AvailTC, AvailName, AvailFL #-} pattern AvailTC :: Name -> [Name] -> [FieldLabel] -> Avail.AvailInfo -#if __GLASGOW_HASKELL__ >= 902 +#if __GLASGOW_HASKELL__ >= 907 +pattern AvailTC n names pieces <- Avail.AvailTC n ((,[]) -> (names,pieces)) +#elif __GLASGOW_HASKELL__ >= 902 pattern AvailTC n names pieces <- Avail.AvailTC n ((\gres -> foldr (\gre (names, pieces) -> case gre of Avail.NormalGreName name -> (name: names, pieces) Avail.FieldGreName label -> (names, label:pieces)) ([], []) gres) -> (names, pieces)) @@ -191,14 +196,18 @@ #endif pattern AvailName :: Name -> Avail.AvailInfo -#if __GLASGOW_HASKELL__ >= 902 +#if __GLASGOW_HASKELL__ >= 907 +pattern AvailName n <- Avail.Avail n +#elif __GLASGOW_HASKELL__ >= 902 pattern AvailName n <- Avail.Avail (Avail.NormalGreName n) #else pattern AvailName n <- Avail.Avail n #endif pattern AvailFL :: FieldLabel -> Avail.AvailInfo -#if __GLASGOW_HASKELL__ >= 902 +#if __GLASGOW_HASKELL__ >= 907 +pattern AvailFL fl <- (const Nothing -> Just fl) -- this pattern always fails as this field was removed in 9.7 +#elif __GLASGOW_HASKELL__ >= 902 pattern AvailFL fl <- Avail.Avail (Avail.FieldGreName fl) #else -- pattern synonym that is never populated @@ -214,4 +223,9 @@ field_label = id #endif - +dfs :: Ord a => Graph.AdjacencyMap a -> [a] -> [a] +#if MIN_VERSION_algebraic_graphs(0,7,0) +dfs = Graph.dfs +#else +dfs = flip Graph.dfs +#endif diff --git a/src/HieDb/Create.hs b/src/HieDb/Create.hs --- a/src/HieDb/Create.hs +++ b/src/HieDb/Create.hs @@ -26,6 +26,7 @@ import Data.String import System.Directory +import System.FilePath import Database.SQLite.Simple @@ -210,15 +211,28 @@ 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 -> FilePath -> m Bool -addRefsFrom c@(getConn -> conn) path = do +addRefsFrom :: (MonadIO m, NameCacheMonad m) => HieDb -> Maybe FilePath -> FilePath -> m Bool +addRefsFrom c@(getConn -> conn) mSrcBaseDir path = do hash <- liftIO $ getFileHash path mods <- liftIO $ query conn "SELECT * FROM mods WHERE hieFile = ? AND hash = ?" (path, hash) case mods of (HieModuleRow{}:_) -> pure False [] -> do - withHieFile path $ addRefsFromLoaded c path (FakeFile Nothing) hash + withHieFile path $ addRefsWithFile hash pure True + where + addRefsWithFile :: MonadIO m => Fingerprint -> HieFile -> m () + addRefsWithFile hash hieFile = do + srcfile <- liftIO $ + maybe + (pure . FakeFile $ Nothing) + (\srcBaseDir -> do + srcFullPath <- makeAbsolute (srcBaseDir hie_hs_file hieFile) + fileExists <- doesFileExist srcFullPath + pure $ if fileExists then RealFile srcFullPath else (FakeFile Nothing) + ) + mSrcBaseDir + addRefsFromLoaded c path srcfile hash hieFile addRefsFromLoaded :: MonadIO m @@ -290,6 +304,15 @@ -> IO () addSrcFile (getConn -> conn) hie srcFile isReal = execute conn "UPDATE mods SET hs_src = ? , is_real = ? WHERE hieFile = ?" (srcFile, isReal, hie) + +{-| Remove the path to .hs source for all dependency @.hie@ files. Useful for resetting +the indexed dependencies if the sources have been deleted for some reason. +-} +removeDependencySrcFiles + :: HieDb + -> IO () +removeDependencySrcFiles (getConn -> conn) = + execute conn "UPDATE mods SET hs_src = NULL WHERE NOT is_real" () {-| Delete all occurrences of given @.hie@ file from the database -} deleteFileFromIndex :: HieDb -> FilePath -> IO () diff --git a/src/HieDb/Query.hs b/src/HieDb/Query.hs --- a/src/HieDb/Query.hs +++ b/src/HieDb/Query.hs @@ -6,7 +6,6 @@ module HieDb.Query where import Algebra.Graph.AdjacencyMap (AdjacencyMap, edges, vertexSet, vertices, overlay) -import Algebra.Graph.AdjacencyMap.Algorithm (dfs) import Algebra.Graph.Export.Dot hiding ((:=)) import qualified Algebra.Graph.Export.Dot as G @@ -78,6 +77,11 @@ \((NOT :real) OR (mods.is_real AND mods.hs_src IS NOT NULL))" <> " AND mods.hs_src NOT IN (" <> Query (T.intercalate "," (map (\(l := _) -> l) excludedFields)) <> ")" +{-| Lookup all 'HieModule' rows from 'HieDb' that are part of a given 'Unit' -} +lookupPackage :: HieDb -> Unit -> IO [HieModuleRow] +lookupPackage (getConn -> conn) uid = + query conn "SELECT * FROM mods WHERE unit = ?" (Only uid) + {-| Lookup 'HieModule' row from 'HieDb' given its 'ModuleName' and 'Unit' -} lookupHieFile :: HieDb -> ModuleName -> Unit -> IO (Maybe HieModuleRow) lookupHieFile (getConn -> conn) mn uid = do @@ -102,6 +106,18 @@ ++ show fp ++ ". Entries: " ++ intercalate ", " (map (show . toRow) xs) +{-| Lookup 'HieModule' row from 'HieDb' given the hash of the HIE file -} +lookupHieFileFromHash :: HieDb -> Fingerprint -> IO (Maybe HieModuleRow) +lookupHieFileFromHash (getConn -> conn) hash = do + files <- query conn "SELECT * FROM mods WHERE hash = ?" (Only hash) + case files of + [] -> return Nothing + [x] -> return $ Just x + xs -> + error $ "DB invariant violated, hash in mods not unique: " + ++ show hash ++ ". Entries: " + ++ intercalate ", " (map (show . toRow) xs) + findTypeRefs :: HieDb -> Bool -> OccName -> Maybe ModuleName -> Maybe Unit -> [FilePath] -> IO [Res TypeRef] findTypeRefs (getConn -> conn) isReal occ mn uid exclude = queryNamed conn thisQuery ([":occ" := occ, ":mod" := mn, ":unit" := uid, ":real" := isReal] ++ excludedFields) @@ -267,4 +283,4 @@ return (Set.toList xs, Set.toList ys) splitByReachability :: Ord a => AdjacencyMap a -> [a] -> (Set a, Set a) -splitByReachability m vs = let s = Set.fromList (dfs vs m) in (s, vertexSet m Set.\\ s) +splitByReachability m vs = let s = Set.fromList (dfs m vs) in (s, vertexSet m Set.\\ s) diff --git a/src/HieDb/Run.hs b/src/HieDb/Run.hs --- a/src/HieDb/Run.hs +++ b/src/HieDb/Run.hs @@ -79,6 +79,7 @@ , context :: Maybe Natural , reindex :: Bool , keepMissing :: Bool + , srcBaseDir :: Maybe FilePath } data Command @@ -125,6 +126,7 @@ <*> optional (option auto (long "context" <> short 'C' <> help "Number of lines of context for source spans - show no context by default")) <*> 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")) where colourFlag = flag' True (long "colour" <> long "color" <> help "Force coloured output") <|> flag' False (long "no-colour" <> long "no-color" <> help "Force uncoloured ouput") @@ -236,7 +238,7 @@ istart <- offsetTime (length -> done, length -> skipped)<- runDbM nc $ partition id <$> - zipWithM (\f n -> progress' h (length files) n (addRefsFrom conn) f) files [0..] + zipWithM (\f n -> progress' h (length files) n (addRefsFrom conn (srcBaseDir opts)) f) files [0..] indexTime <- istart start <- offsetTime diff --git a/src/HieDb/Utils.hs b/src/HieDb/Utils.hs --- a/src/HieDb/Utils.hs +++ b/src/HieDb/Utils.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -370,4 +370,5 @@ , context = Nothing , reindex = False , keepMissing = False + , srcBaseDir = Nothing }