Depth limit positions, use hashes instead of mtime

CHANGELOG.md

@@ -1,5 +1,11 @@
 # Revision history for hiedb
 
+## 0.2.0.0 -- 2021-01-06
+
+* Use fingerprints/hashes instead of modtimes to maintin database consistency
+* Type references are depth limited
+* Total time taken to index is reported
+
 ## 0.1.0.0 -- 2020-11-08
 
 * First version.

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 @@ library
                      , mtl
                      , sqlite-simple
                      , hie-compat
-                     , time
                      , text
                      , bytestring
                      , algebraic-graphs
                      , lucid
                      , optparse-applicative
+                     , extra
                      , terminal-size
 
 test-suite hiedb-tests

src/HieDb/Create.hs

@@ -18,13 +18,11 @@ import Control.Monad.IO.Class
 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 qualified Data.Map as M
 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 @@ initConn (getConn -> conn) = do
                 \, 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 \
                 \)"
 
@@ -183,22 +181,22 @@ The indexing is skipped if the file was not modified since the last time it was
 -}
 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
   => HieDb -- ^ HieDb into which we're adding the file
   -> 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 +207,7 @@ addRefsFromLoaded db@(getConn -> conn) path srcFile isReal time hf = liftIO $ wi
       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
 

src/HieDb/Query.hs

@@ -48,7 +48,7 @@ or if ModuleName is ambiguous (i.e. there are multiple packages containing modul
 -}
 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
@@ -60,7 +60,7 @@ search (getConn -> conn) isReal occ mn uid exclude =
   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))"
       <> " AND mods.hs_src NOT IN (" <> Query (T.intercalate "," (map (\(l := _) -> l) excludedFields)) <> ")"
@@ -91,7 +91,7 @@ lookupHieFileFromSource (getConn -> conn) fp = do
 
 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 \
+  = query conn  "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 = ? AND typenames.mod = ? AND typenames.unit = ? AND mods.is_real \
@@ -100,7 +100,7 @@ findTypeRefs (getConn -> conn) occ mn uid
 
 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 +115,7 @@ findOneDef conn occ mn muid = wrap <$> findDef conn occ mn muid
 
 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++"%")

src/HieDb/Run.hs

@@ -23,6 +23,7 @@ import System.Environment
 import System.Directory
 import System.IO
 import System.Exit
+import System.Time.Extra
 
 import System.Console.Terminal.Size
 
@@ -187,11 +188,15 @@ hieTarget =
       (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,12 +212,14 @@ runCommand libdir opts cmd = withHieDbAndFlags libdir (database opts) $ \dynFlag
       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 []

src/HieDb/Types.hs

@@ -13,6 +13,7 @@ import Prelude hiding (mod)
 import Name
 import Module
 import NameCache
+import Fingerprint
 
 import IfaceEnv (NameCacheUpdater(..))
 import Data.IORef
@@ -25,7 +26,6 @@ import Control.Exception
 
 import Data.List.NonEmpty (NonEmpty(..))
 
-import Data.Time.Clock
 import Data.Int
 
 import Database.SQLite.Simple
@@ -54,7 +54,7 @@ data ModuleInfo
                           -- 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
@@ -78,6 +78,11 @@ instance ToField UnitId where
 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
   | isVarNameSpace ns = 'v'

src/HieDb/Utils.hs

@@ -47,6 +47,9 @@ import Data.IORef
 import HieDb.Types
 import Database.SQLite.Simple
 
+maxDepth :: Int
+maxDepth = 2
+
 addTypeRef :: HieDb -> FilePath -> A.Array TypeIndex HieTypeFlat -> A.Array TypeIndex (Maybe Int64) -> RealSrcSpan -> TypeIndex -> IO ()
 addTypeRef (getConn -> conn) hf arr ixs sp = go 0
   where
@@ -55,7 +58,9 @@ addTypeRef (getConn -> conn) hf arr ixs sp = go 0
     el = srcSpanEndLine sp
     ec = srcSpanEndCol sp
     go :: TypeIndex -> Int -> IO ()
-    go d i = do
+    go d i
+      | d > maxDepth = pure ()
+      | otherwise = do
       case ixs A.! i of
         Nothing -> pure ()
         Just occ -> do
@@ -74,7 +79,7 @@ addTypeRef (getConn -> conn) hf arr ixs sp = go 0
         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