diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,14 @@ # Revision history for hiedb +## 0.2.0.0 -- 2021-01-06 + +* Use fingerprints/hashes instead of modtimes to maintin database consistency +* Type references are only reported for bind sites +* Type references are computed for all files +* Total time taken to index is reported +* `search` is now called `findReferences` +* `findTypeRefs` has a similar type signature to `findReferences` + ## 0.1.0.0 -- 2020-11-08 * First version. 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.1.0.0 +version: 0.2.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 @@ -55,12 +55,12 @@ , mtl , sqlite-simple , hie-compat - , time , text , bytestring , algebraic-graphs , lucid , optparse-applicative + , extra , terminal-size test-suite hiedb-tests diff --git a/src/HieDb/Create.hs b/src/HieDb/Create.hs --- a/src/HieDb/Create.hs +++ b/src/HieDb/Create.hs @@ -18,13 +18,11 @@ import Control.Monad import Control.Exception -import System.Directory - import Database.SQLite.Simple -import Data.Time.Clock import Data.List ( isSuffixOf ) import Data.String import Data.Int +import GHC.Fingerprint import HieDb.Types import HieDb.Utils @@ -33,7 +31,7 @@ import Data.Maybe sCHEMA_VERSION :: Integer -sCHEMA_VERSION = 4 +sCHEMA_VERSION = 5 dB_VERSION :: Integer dB_VERSION = read (show sCHEMA_VERSION ++ "999" ++ show hieVersion) @@ -81,7 +79,7 @@ \, is_boot BOOL NOT NULL \ \, hs_src TEXT UNIQUE ON CONFLICT REPLACE \ \, is_real BOOL NOT NULL \ - \, time TEXT NOT NULL \ + \, hash TEXT NOT NULL UNIQUE ON CONFLICT REPLACE \ \, CONSTRAINT modid UNIQUE (mod, unit, is_boot) ON CONFLICT REPLACE \ \)" @@ -173,9 +171,11 @@ asts = getAsts $ hie_asts hf addTypesFromAst :: HieAST TypeIndex -> IO () addTypesFromAst ast = do - mapM_ (addTypeRef db path arr ixs (nodeSpan ast)) $ mapMaybe identType $ M.elems $ nodeIdentifiers $ nodeInfo ast - when (null $ nodeChildren ast) $ - mapM_ (addTypeRef db path arr ixs (nodeSpan ast)) $ nodeType $ nodeInfo ast + mapM_ (addTypeRef db path arr ixs (nodeSpan ast)) + $ mapMaybe (\x -> guard (any (not . isOccurrence) (identInfo x)) *> identType x) + $ M.elems + $ nodeIdentifiers + $ nodeInfo ast mapM_ addTypesFromAst $ nodeChildren ast {-| Adds all references from given @.hie@ file to 'HieDb'. @@ -183,11 +183,11 @@ -} addRefsFrom :: (MonadIO m, NameCacheMonad m) => HieDb -> FilePath -> m () addRefsFrom c@(getConn -> conn) path = do - time <- liftIO $ getModificationTime path - mods <- liftIO $ query conn "SELECT * FROM mods WHERE hieFile = ? AND time >= ?" (path, time) + hash <- liftIO $ getFileHash path + mods <- liftIO $ query conn "SELECT * FROM mods WHERE hieFile = ? AND hash = ?" (path, hash) case mods of (HieModuleRow{}:_) -> return () - [] -> withHieFile path $ \hf -> addRefsFromLoaded c path Nothing False time hf + [] -> withHieFile path $ \hf -> addRefsFromLoaded c path Nothing False hash hf addRefsFromLoaded :: MonadIO m @@ -195,10 +195,10 @@ -> FilePath -- ^ Path to @.hie@ file -> Maybe FilePath -- ^ Path to .hs file from which @.hie@ file was created -> Bool -- ^ Is this a real source file? I.e. does it come from user's project (as opposed to from project's dependency)? - -> UTCTime -- ^ The last modification time of the @.hie@ file + -> Fingerprint -- ^ The hash of the @.hie@ file -> HieFile -- ^ Data loaded from the @.hie@ file -> m () -addRefsFromLoaded db@(getConn -> conn) path srcFile isReal time hf = liftIO $ withTransaction conn $ do +addRefsFromLoaded db@(getConn -> conn) path srcFile isReal hash hf = liftIO $ withTransaction conn $ do execute conn "DELETE FROM refs WHERE hieFile = ?" (Only path) execute conn "DELETE FROM decls WHERE hieFile = ?" (Only path) execute conn "DELETE FROM defs WHERE hieFile = ?" (Only path) @@ -209,7 +209,7 @@ uid = moduleUnitId smod smod = hie_module hf refmap = generateReferencesMap $ getAsts $ hie_asts hf - modrow = HieModuleRow path (ModuleInfo mod uid isBoot srcFile isReal time) + modrow = HieModuleRow path (ModuleInfo mod uid isBoot srcFile isReal hash) execute conn "INSERT INTO mods VALUES (?,?,?,?,?,?,?)" modrow @@ -217,13 +217,11 @@ executeMany conn "INSERT INTO refs VALUES (?,?,?,?,?,?,?,?)" rows executeMany conn "INSERT INTO decls VALUES (?,?,?,?,?,?,?)" decls - ixs <- addArr db (hie_types hf) - let defs = genDefRow path smod refmap executeMany conn "INSERT INTO defs VALUES (?,?,?,?,?,?)" defs - when isReal $ - addTypeRefs db path hf ixs + ixs <- addArr db (hie_types hf) + 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. diff --git a/src/HieDb/Query.hs b/src/HieDb/Query.hs --- a/src/HieDb/Query.hs +++ b/src/HieDb/Query.hs @@ -35,7 +35,6 @@ import HieDb.Dump (sourceCode) import HieDb.Types import HieDb.Utils -import HieDb.Create import qualified HieDb.Html as Html {-| List all modules indexed in HieDb. -} @@ -48,21 +47,22 @@ -} resolveUnitId :: HieDb -> ModuleName -> IO (Either HieDbErr UnitId) resolveUnitId (getConn -> conn) mn = do - luid <- query conn "SELECT mod, unit, is_boot, hs_src, is_real, time FROM mods WHERE mod = ? and is_boot = 0" (Only mn) + luid <- query conn "SELECT mod, unit, is_boot, hs_src, is_real, hash FROM mods WHERE mod = ? and is_boot = 0" (Only mn) return $ case luid of [] -> Left $ NotIndexed mn Nothing [x] -> Right $ modInfoUnit x (x:xs) -> Left $ AmbiguousUnitId $ x :| xs -search :: HieDb -> Bool -> OccName -> Maybe ModuleName -> Maybe UnitId -> [FilePath] -> IO [Res RefRow] -search (getConn -> conn) isReal occ mn uid exclude = +findReferences :: HieDb -> Bool -> OccName -> Maybe ModuleName -> Maybe UnitId -> [FilePath] -> IO [Res RefRow] +findReferences (getConn -> conn) isReal occ mn uid exclude = queryNamed conn thisQuery ([":occ" := occ, ":mod" := mn, ":unit" := uid, ":real" := isReal] ++ excludedFields) where excludedFields = zipWith (\n f -> (":exclude" <> T.pack (show n)) := f) [1 :: Int ..] exclude thisQuery = - "SELECT refs.*,mods.mod,mods.unit,mods.is_boot,mods.hs_src,mods.is_real,mods.time \ + "SELECT refs.*,mods.mod,mods.unit,mods.is_boot,mods.hs_src,mods.is_real,mods.hash \ \FROM refs JOIN mods USING (hieFile) \ - \WHERE refs.occ = :occ AND (:mod IS NULL OR refs.mod = :mod) AND (:unit is NULL OR refs.unit = :unit) AND ( (NOT :real) OR (mods.is_real AND mods.hs_src IS NOT NULL))" + \WHERE refs.occ = :occ AND (:mod IS NULL OR refs.mod = :mod) AND (:unit is NULL OR refs.unit = :unit) AND \ + \((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 'HieModule' row from 'HieDb' given its 'ModuleName' and 'UnitId' -} @@ -89,18 +89,23 @@ ++ show fp ++ ". Entries: " ++ intercalate ", " (map (show . toRow) xs) -findTypeRefs :: HieDb -> OccName -> ModuleName -> UnitId -> IO [Res TypeRef] -findTypeRefs (getConn -> conn) occ mn uid - = query conn "SELECT typerefs.*, mods.mod,mods.unit,mods.is_boot,mods.hs_src,mods.is_real,mods.time \ - \FROM typerefs JOIN mods ON typerefs.hieFile = mods.hieFile \ - \JOIN typenames ON typerefs.id = typenames.id \ - \WHERE typenames.name = ? AND typenames.mod = ? AND typenames.unit = ? AND mods.is_real \ - \ORDER BY typerefs.depth ASC" - (occ,mn,uid) +findTypeRefs :: HieDb -> Bool -> OccName -> Maybe ModuleName -> Maybe UnitId -> [FilePath] -> IO [Res TypeRef] +findTypeRefs (getConn -> conn) isReal occ mn uid exclude + = queryNamed conn thisQuery ([":occ" := occ, ":mod" := mn, ":unit" := uid, ":real" := isReal] ++ excludedFields) + where + excludedFields = zipWith (\n f -> (":exclude" <> T.pack (show n)) := f) [1 :: Int ..] exclude + thisQuery = + "SELECT typerefs.*, mods.mod,mods.unit,mods.is_boot,mods.hs_src,mods.is_real,mods.hash \ + \FROM typerefs JOIN mods ON typerefs.hieFile = mods.hieFile \ + \JOIN typenames ON typerefs.id = typenames.id \ + \WHERE typenames.name = :occ AND (:mod IS NULL OR typenames.mod = :mod) AND \ + \(:unit IS NULL OR typenames.unit = :unit) AND ((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)) <> ")" + <> " ORDER BY typerefs.depth ASC" findDef :: HieDb -> OccName -> Maybe ModuleName -> Maybe UnitId -> IO [Res DefRow] findDef conn occ mn uid - = queryNamed (getConn conn) "SELECT defs.*, mods.mod,mods.unit,mods.is_boot,mods.hs_src,mods.is_real,mods.time \ + = queryNamed (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 = :occ AND (:mod IS NULL OR mod = :mod) AND (:unit IS NULL OR unit = :unit)" [":occ" := occ,":mod" := mn, ":unit" := uid] @@ -115,7 +120,7 @@ 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.time \ + = 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++"%") @@ -145,7 +150,6 @@ fp' <- canonicalizePath fp nc <- newIORef =<< makeNc runDbM nc $ do - addRefsFrom conn fp' Right <$> withHieFile fp' (return . f) diff --git a/src/HieDb/Run.hs b/src/HieDb/Run.hs --- a/src/HieDb/Run.hs +++ b/src/HieDb/Run.hs @@ -23,6 +23,7 @@ import System.Directory import System.IO import System.Exit +import System.Time.Extra import System.Console.Terminal.Size @@ -187,11 +188,15 @@ (Left <$> strOption (long "hiefile" <> short 'f' <> metavar "HIEFILE")) <|> (Right <$> ((,) <$> moduleNameParser <*> maybeUnitId)) -progress :: Int -> Int -> Int -> (FilePath -> DbMonad a) -> FilePath -> DbMonad a -progress l total cur act f = do - liftIO $ putStr $ replicate l ' ' - liftIO $ putStr "\r" - let msg = take (l-8) $ unwords ["Processing file", show (cur + 1) ++ "/" ++ show total ++ ":", f] ++ "..." +progress :: Maybe Int -> Int -> Int -> (FilePath -> DbMonad a) -> FilePath -> DbMonad a +progress mw total cur act f = do + let msg' = unwords ["Processing file", show (cur + 1) ++ "/" ++ show total ++ ":", f] ++ "..." + msg <- liftIO $ case mw of + Nothing -> putStrLn "" >> pure msg' + Just w -> do + putStr $ replicate w ' ' + putStr "\r" + pure $ take (w-8) $ msg' liftIO $ putStr msg x <- act f liftIO $ putStr " done\r" @@ -207,20 +212,22 @@ initConn conn files <- concat <$> mapM getHieFilesIn dirs nc <- newIORef =<< makeNc - wsize <- maybe 80 width <$> size + wsize <- fmap width <$> size let progress' = if quiet opts then (\_ _ _ k -> k) else progress + start <- offsetTime runDbM nc $ zipWithM_ (\f n -> progress' wsize (length files) n (addRefsFrom conn) f) files [0..] + end <- start unless (quiet opts) $ - putStrLn "\nCompleted!" + putStrLn $ "\nCompleted! (" <> showDuration end <> ")" TypeRefs typ mn muid -> do let occ = mkOccName tcClsName typ - refs <- search conn False occ mn muid [] + refs <- findReferences conn False occ mn muid [] reportRefs refs NameRefs nm mn muid -> do let ns = if isCons nm then dataName else varName let occ = mkOccName ns nm - refs <- search conn False occ mn muid [] + refs <- findReferences conn False occ mn muid [] reportRefs refs NameDef nm mn muid -> do let ns = if isCons nm then dataName else varName @@ -277,7 +284,7 @@ putStrLn $ unwords ["Name", occNameString (nameOccName name),"at",show sp,"is used in:"] case nameModule_maybe name of Just mod -> do - reportRefs =<< search conn False (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnitId mod) [] + reportRefs =<< findReferences conn False (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnitId mod) [] Nothing -> do let refmap = generateReferencesMap (getAsts $ hie_asts hf) refs = map (toRef . fst) $ M.findWithDefault [] (Right name) refmap diff --git a/src/HieDb/Types.hs b/src/HieDb/Types.hs --- a/src/HieDb/Types.hs +++ b/src/HieDb/Types.hs @@ -13,6 +13,7 @@ import Name import Module import NameCache +import Fingerprint import IfaceEnv (NameCacheUpdater(..)) import Data.IORef @@ -25,7 +26,6 @@ import Data.List.NonEmpty (NonEmpty(..)) -import Data.Time.Clock import Data.Int import Database.SQLite.Simple @@ -54,7 +54,7 @@ -- False when it was created from @.hie@ file , modInfoSrcFile :: Maybe FilePath -- ^ The path to the haskell source file, from which the @.hie@ file was created , modInfoIsReal :: Bool -- ^ Is this a real source file? I.e. does it come from user's project (as opposed to from project's dependency)? - , modInfoTime :: UTCTime -- ^ The last modification time of the @.hie@ file from which this ModuleInfo was created + , modInfoHash :: Fingerprint -- ^ The hash of the @.hie@ file from which this ModuleInfo was created } instance Show ModuleInfo where @@ -77,6 +77,11 @@ toField uid = SQLText $ T.pack $ unitIdString uid instance FromField UnitId where fromField fld = stringToUnitId . T.unpack <$> fromField fld + +instance ToField Fingerprint where + toField hash = SQLText $ T.pack $ show hash +instance FromField Fingerprint where + fromField fld = readHexFingerprint . T.unpack <$> fromField fld toNsChar :: NameSpace -> Char toNsChar ns diff --git a/src/HieDb/Utils.hs b/src/HieDb/Utils.hs --- a/src/HieDb/Utils.hs +++ b/src/HieDb/Utils.hs @@ -74,7 +74,7 @@ HFunTy a b -> mapM_ next [a,b] HQualTy a b -> mapM_ next [a,b] HLitTy _ -> pure () - HCastTy a -> next a + HCastTy a -> go d a HCoercionTy -> pure () makeNc :: IO NameCache