hiedb 0.2.0.0 → 0.3.0.0

raw patch · 7 files changed

+451/−133 lines, 7 filesdep +ansi-terminaldep +temporarydep −terminal-sizePVP ok

version bump matches the API change (PVP)

Dependencies added: ansi-terminal, temporary

Dependencies removed: terminal-size

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• README.md +53/−0
• hiedb.cabal +6/−3
• src/HieDb/Create.hs +57/−20
• src/HieDb/Run.hs +224/−83
• src/HieDb/Types.hs +12/−2
• test/Main.hs +93/−25

@@ -1,5 +1,11 @@ # Revision history for hiedb +## 0.3.0.0 -- 2021-01-20++* Introduce `SourceFile` type+* Add `deleteMissingRealFiles` to garbage collect missing/deleted files+* Enforce `is_real => hs_src IS NOT NULL` constraint in database.+ ## 0.2.0.0 -- 2021-01-06  * Use fingerprints/hashes instead of modtimes to maintin database consistency

@@ -0,0 +1,53 @@+# HIE DB - A tool to index and query .hie files++## Compiling++### Prerequisites++- Recent version of GHC 8.8/HEAD which includes support for .hie files+- cabal >= 2.4.1.0++### Procedure++```+$ cabal install hiedb+```++## Usage++### Generating .hie files++Compile any package with ghc options `-fwrite-ide-info` and optionally,+`-hiedir <dir>`. This will generate `.hie` files and save them in `<dir>`++### Indexing++```+$ hiedb -D <db-loc> index <hiedir>+```++You can omit `<db-loc>`, in which case it will default to the environment variable+`HIEDB`, or if that is not defined, `$XDG_DATA_DIR/default_$DBVERSION.hiedb`++### Querying++- Looking up references for a name(value/data constructor):+  ```+  $ hiedb -D <db-loc> name-refs <NAME> [MODULE]+  ```+- Looking up references for a type:+  ```+  $ hiedb -D <db-loc> type-refs <NAME> [MODULE]+  ```++`MODULE` is the module the name was originaly defined in.++- Looking up references for a symbol at a particular location:+  ```+  $ hiedb -D -<db-loc> point-refs (-f|--hiefile HIEFILE) SLINE SCOL [ELINE] [ECOL]  +  $ hiedb -D -<db-loc> point-refs MODULE [-u|--unit-id UNITID] SLINE SCOL [ELINE] [ECOL]+  ```++You can either lookup references for a Module that is already indexed,+or lookup references for a point in a .hie file directly, which will be+(re)indexed.

@@ -1,6 +1,6 @@ cabal-version:       2.4 name:                hiedb-version:             0.2.0.0+version:             0.3.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,7 +10,9 @@ maintainer:          zubin.duggal@gmail.com copyright:           Zubin Duggal category:            Development-extra-source-files:  CHANGELOG.md+extra-source-files:+  CHANGELOG.md+  README.md   source-repository head@@ -61,7 +63,7 @@                      , lucid                      , optparse-applicative                      , extra-                     , terminal-size+                     , ansi-terminal  test-suite hiedb-tests   import:             common-options@@ -77,3 +79,4 @@                     , hiedb                     , hspec                     , process+                    , temporary

@@ -8,27 +8,32 @@  import Prelude hiding (mod) -import GHC import Compat.HieTypes import Compat.HieUtils++import GHC import IfaceType import Name+import GHC.Fingerprint -import Control.Monad.IO.Class-import Control.Monad import Control.Exception+import Control.Monad+import Control.Monad.IO.Class -import Database.SQLite.Simple+import qualified Data.Array as A+import qualified Data.Map as M++import Data.Int import Data.List ( isSuffixOf )+import Data.Maybe import Data.String-import Data.Int-import GHC.Fingerprint +import System.Directory++import Database.SQLite.Simple+ import HieDb.Types import HieDb.Utils-import qualified Data.Array as A-import qualified Data.Map as M-import Data.Maybe  sCHEMA_VERSION :: Integer sCHEMA_VERSION = 5@@ -81,6 +86,7 @@                 \, is_real BOOL NOT NULL \                 \, hash    TEXT NOT NULL UNIQUE ON CONFLICT REPLACE \                 \, CONSTRAINT modid UNIQUE (mod, unit, is_boot) ON CONFLICT REPLACE \+                \, CONSTRAINT real_has_src CHECK ( (NOT is_real) OR (hs_src IS NOT NULL) ) \                 \)"    execute_ conn "CREATE TABLE IF NOT EXISTS refs \@@ -136,6 +142,7 @@                 \, FOREIGN KEY(id) REFERENCES typenames(id) DEFERRABLE INITIALLY DEFERRED \                 \, FOREIGN KEY(hieFile) REFERENCES mods(hieFile) ON UPDATE CASCADE ON DELETE CASCADE DEFERRABLE INITIALLY DEFERRED \                 \)"+  execute_ conn "CREATE INDEX IF NOT EXISTS typeref_id ON typerefs(id)"  {-| Add names of types from @.hie@ file to 'HieDb'. Returns an Array mapping 'TypeIndex' to database ID assigned to the @@ -180,35 +187,39 @@  {-| 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 -> FilePath -> m ()+addRefsFrom :: (MonadIO m, NameCacheMonad m) => HieDb -> FilePath -> m Bool addRefsFrom c@(getConn -> conn) path = do   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 hash hf+    (HieModuleRow{}:_) -> pure False+    [] -> do+      withHieFile path $ addRefsFromLoaded c path (FakeFile Nothing) hash+      pure True  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)?+  -> 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   -> HieFile -- ^ Data loaded from the @.hie@ file   -> m ()-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)-  execute conn "DELETE FROM typerefs WHERE hieFile = ?" (Only path)+addRefsFromLoaded db@(getConn -> conn) path sourceFile hash hf = liftIO $ withTransaction conn $ do+  deleteInternalTables conn path    let isBoot = "boot" `isSuffixOf` path       mod    = moduleName smod       uid    = moduleUnitId smod       smod   = hie_module hf       refmap = generateReferencesMap $ getAsts $ hie_asts hf+      (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@@ -238,7 +249,33 @@ {-| Delete all occurrences of given @.hie@ file from the database -} deleteFileFromIndex :: HieDb -> FilePath -> IO () deleteFileFromIndex (getConn -> conn) path = withTransaction conn $ do-  execute conn "DELETE FROM mods  WHERE hieFile = ?" (Only path)+  deleteInternalTables conn 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+  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++{-| Garbage collect typenames with no references - it is a good idea to call+this function after a sequence of database updates (inserts or deletes)+-}+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 )"+  changes conn++deleteInternalTables :: Connection -> FilePath -> IO ()+deleteInternalTables conn path = 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)+  execute conn "DELETE FROM typerefs WHERE hieFile = ?" (Only path)+  execute conn "DELETE FROM mods  WHERE hieFile = ?" (Only path)

@@ -1,6 +1,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE LambdaCase #-} module HieDb.Run where  import Prelude hiding (mod)@@ -11,6 +13,7 @@ import Name import Module import Outputable ((<+>),hang,showSDoc,ppr,text)+import IfaceType (IfaceType)  import qualified FastString as FS @@ -22,10 +25,11 @@ import System.Environment import System.Directory import System.IO+import System.IO.Unsafe (unsafeInterleaveIO) import System.Exit import System.Time.Extra -import System.Console.Terminal.Size+import System.Console.ANSI  import Control.Monad import Control.Monad.IO.Class@@ -34,7 +38,10 @@ import Data.Either import Data.Foldable import Data.IORef+import Data.List.Extra +import Numeric.Natural+ import qualified Data.ByteString.Char8 as BS  import Options.Applicative@@ -46,8 +53,9 @@ hiedbMain libdir = do   defaultLoc <- getXdgDirectory XdgData $ "default_"++ show dB_VERSION ++".hiedb"   defdb <- fromMaybe defaultLoc <$> lookupEnv "HIEDB"+  colr <- hSupportsANSIColor stdout   hSetBuffering stdout NoBuffering-  (opts, cmd) <- execParser $ progParseInfo defdb+  (opts, cmd) <- execParser $ progParseInfo defdb colr   runCommand libdir opts cmd  @@ -67,7 +75,10 @@   { database :: FilePath   , trace :: Bool   , quiet :: Bool-  , virtualFile :: Bool+  , colour :: Bool+  , context :: Maybe Natural+  , reindex :: Bool+  , keepMissing :: Bool   }  data Command@@ -91,30 +102,38 @@   | Reachable [Symbol]   | Unreachable [Symbol]   | Html [Symbol]+  | GCTypeNames -progParseInfo :: FilePath -> ParserInfo (Options, Command)-progParseInfo db = info (progParser db <**> helper)+progParseInfo :: FilePath -> Bool -> ParserInfo (Options, Command)+progParseInfo db colr = info (progParser db colr <**> helper)   ( fullDesc   <> progDesc "Query .hie files"   <> header "hiedb - a tool to query groups of .hie files" ) -progParser :: FilePath -> Parser (Options,Command)-progParser db = (,) <$> optParser db <*> cmdParser+progParser :: FilePath -> Bool -> Parser (Options,Command)+progParser db colr = (,) <$> optParser db colr <*> cmdParser -optParser :: FilePath -> Parser Options-optParser defdb+optParser :: FilePath -> Bool -> Parser Options+optParser defdb colr     = Options   <$> strOption (long "database" <> short 'D' <> metavar "DATABASE"               <> value defdb <> showDefault <> help "References Database")   <*> switch (long "trace" <> short 'v' <> help "Print SQL queries being executed")   <*> switch (long "quiet" <> short 'q' <> help "Don't print progress messages")-  <*> switch (long "virtual-file" <> short 'f' <> internal)+  <*> colourFlag+  <*> 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")+  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  cmdParser :: Parser Command cmdParser    = hsubparser    $ command "init" (info (pure Init) $ progDesc "Initialize database")-  <> command "index" (info (Index <$> many (strArgument (metavar "DIRECTORY..."))) $ progDesc "Index database")+  <> command "index" (info (Index <$> many (strArgument (metavar "DIRECTORY..."))) $ progDesc "Index files from directory")   <> command "name-refs" (info (NameRefs <$> strArgument (metavar "NAME")                                          <*> optional (mkModuleName <$> strArgument (metavar "MODULE"))                                          <*> maybeUnitId)@@ -169,6 +188,7 @@                            $ progDesc "Find all symbols unreachable from the given symbols")   <> command "html" (info (Html <$> some symbolParser)                     $ progDesc "generate html files for reachability from the given symbols")+  <> command "gc" (info (pure GCTypeNames) mempty)  posParser :: Char -> Parser (Int,Int) posParser c = (,) <$> argument auto (metavar $ c:"LINE") <*> argument auto (metavar $ c:"COL")@@ -188,59 +208,84 @@       (Left <$> strOption (long "hiefile" <> short 'f' <> metavar "HIEFILE"))   <|> (Right <$> ((,) <$> moduleNameParser  <*> maybeUnitId)) -progress :: Maybe Int -> Int -> Int -> (FilePath -> DbMonad a) -> FilePath -> DbMonad a-progress mw total cur act f = do+progress :: Handle -> Int -> Int -> (FilePath -> DbMonad Bool) -> FilePath -> DbMonad Bool+progress hndl total cur act f = do+  mw <- fmap snd <$> liftIO getTerminalSize   let msg' = unwords ["Processing file", show (cur + 1) ++ "/" ++ show total ++ ":", f] ++ "..."   msg <- liftIO $ case mw of-    Nothing -> putStrLn "" >> pure msg'+    Nothing -> hPutStrLn hndl "" >> pure msg'     Just w -> do-      putStr $ replicate w ' '-      putStr "\r"+      hPutStr hndl $ replicate w ' '+      hPutStr hndl "\r"       pure $ take (w-8) $ msg'-  liftIO $ putStr msg+  liftIO $ hPutStr hndl msg   x <- act f-  liftIO $ putStr " done\r"+  if x+  then liftIO $ hPutStr hndl " done\r"+  else liftIO $ hPutStr hndl " skipped\r"   return x +doIndex :: HieDb -> Options -> Handle -> [FilePath] -> IO ()+doIndex _ opts _ [] | reindex opts = pure ()+doIndex conn opts h files = do+  nc <- newIORef =<< makeNc+  let progress' = if quiet opts then (\_ _ _ k -> k) else progress+  start <- offsetTime+  (length -> done, length -> skipped)<- runDbM nc $ partition id <$>+    zipWithM (\f n -> progress' h (length files) n (addRefsFrom conn) f) files [0..]+  when (done /= 0) $ void $ garbageCollectTypeNames conn++  end <- start+  unless (quiet opts) $+    hPutStrLn h $ "\nCompleted! (" <> show done <> " indexed, " <> show skipped <> " skipped in " <> showDuration end <> ")"+ runCommand :: LibDir -> Options -> Command -> IO () runCommand libdir opts cmd = withHieDbAndFlags libdir (database opts) $ \dynFlags conn -> do   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+      if exists+      then pure $ Just f+      else do+        unless (keepMissing opts) $+          deleteFileFromIndex conn f+        pure Nothing+    let n = length files+        orig = length files'+    unless (quiet opts) $+      hPutStrLn stderr $ "Re-indexing " ++ show n ++ " files, deleting " ++ show (n-orig) ++ " files"+    doIndex conn opts stderr files   case cmd of     Init -> initConn conn     Index dirs -> do       initConn conn       files <- concat <$> mapM getHieFilesIn dirs-      nc <- newIORef =<< makeNc-      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! (" <> showDuration end <> ")"+      doIndex conn opts stderr files     TypeRefs typ mn muid -> do       let occ = mkOccName tcClsName typ       refs <- findReferences conn False occ mn muid []-      reportRefs refs+      reportRefs opts refs     NameRefs nm mn muid -> do       let ns = if isCons nm then dataName else varName       let occ = mkOccName ns nm       refs <- findReferences conn False occ mn muid []-      reportRefs refs+      reportRefs opts refs     NameDef nm mn muid -> do       let ns = if isCons nm then dataName else varName       let occ = mkOccName ns nm-      (row:.inf) <- reportAmbiguousErr =<< findOneDef conn occ mn muid+      (row:.inf) <- reportAmbiguousErr opts =<< findOneDef conn occ mn muid       let mdl = mkModule (modInfoUnit inf) (modInfoName inf)-      reportRefSpans [(mdl, (defSLine row, defSCol row), (defELine row, defECol row))]+      reportRefSpans opts [(mdl, (defSLine row, defSCol row), (defELine row, defECol row),Just $ Left (defSrc row))]     TypeDef nm mn muid -> do       let occ = mkOccName tcClsName nm-      (row:.inf) <- reportAmbiguousErr =<< findOneDef conn occ mn muid+      (row:.inf) <- reportAmbiguousErr opts =<< findOneDef conn occ mn muid       let mdl = mkModule (modInfoUnit inf) (modInfoName inf)-      reportRefSpans [(mdl, (defSLine row, defSCol row), (defELine row, defECol row))]-    Cat target -> hieFileCommand conn target (BS.putStrLn . hie_hs_src)+      reportRefSpans opts [(mdl, (defSLine row, defSCol row), (defELine row, defECol row),Just $ Left (defSrc row))]+    Cat target -> hieFileCommand conn opts target (BS.putStrLn . hie_hs_src)     Ls -> do       mods <- getAllIndexedMods conn       forM_ mods $ \mod -> do@@ -262,14 +307,14 @@                 cf <- canonicalizePath f                 deleteFileFromIndex conn cf             Right (mn,muid) -> do-              uid <- reportAmbiguousErr =<< maybe (resolveUnitId conn mn) (return . Right) muid+              uid <- reportAmbiguousErr opts =<< maybe (resolveUnitId conn mn) (return . Right) muid               mFile <- lookupHieFile conn mn uid               case mFile of-                Nothing -> reportAmbiguousErr $ Left (NotIndexed mn $ Just uid)+                Nothing -> reportAmbiguousErr opts $ Left (NotIndexed mn $ Just uid)                 Just x -> deleteFileFromIndex conn (hieModuleHieFile x)     ModuleUIDs mn ->-      print =<< reportAmbiguousErr =<< resolveUnitId conn mn-    LookupHieFile mn muid -> reportAmbiguousErr =<< do+      print =<< reportAmbiguousErr opts =<< resolveUnitId conn mn+    LookupHieFile mn muid -> reportAmbiguousErr opts =<< do       euid <- maybe (resolveUnitId conn mn) (return . Right) muid       case euid of         Left err -> return $ Left err@@ -278,48 +323,75 @@           case mFile of             Nothing -> return $ Left (NotIndexed mn $ Just uid)             Just x -> Right <$> putStrLn (hieModuleHieFile x)-    RefsAtPoint target sp mep -> hieFileCommand conn target $ \hf -> do+    RefsAtPoint target sp mep -> hieFileCommand conn opts target $ \hf -> do       let names = concat $ pointCommand hf sp mep $ rights . M.keys . nodeIdentifiers . nodeInfo+      when (null names) $+        reportAmbiguousErr opts (Left $ NoNameAtPoint target sp)       forM_ names $ \name -> do-        putStrLn $ unwords ["Name", occNameString (nameOccName name),"at",show sp,"is used in:"]+        unless (quiet opts) $ do+          hPutStrLn stderr $ unwords ["Name", ppName opts (nameOccName name),"at",ppSpan opts sp,"is used at:"]+          hPutStrLn stderr ""         case nameModule_maybe name of           Just mod -> do-            reportRefs =<< findReferences conn False (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnitId mod) []+            reportRefs opts =<< 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-                toRef spn = (hie_module hf,-                              (srcSpanStartLine spn , srcSpanStartCol spn),-                              (srcSpanEndLine spn , srcSpanEndCol spn))-            reportRefSpans refs-    TypesAtPoint target sp mep -> hieFileCommand conn target $ \hf -> do+                toRef spn = (hie_module hf+                            ,(srcSpanStartLine spn , srcSpanStartCol spn)+                            ,(srcSpanEndLine spn , srcSpanEndCol spn)+                            ,Just $ Right (hie_hs_src hf))+            reportRefSpans opts refs+    TypesAtPoint target sp mep -> hieFileCommand conn opts target $ \hf -> do       let types' = concat $ pointCommand hf sp mep $ nodeType . nodeInfo           types = map (flip recoverFullType $ hie_types hf) types'+      when (null types) $+        reportAmbiguousErr opts (Left $ NoNameAtPoint target sp)       forM_ types $ \typ -> do         putStrLn $ renderHieType dynFlags typ-    DefsAtPoint target sp mep -> hieFileCommand conn target $ \hf -> do+    DefsAtPoint target sp mep -> hieFileCommand conn opts target $ \hf -> do       let names = concat $ pointCommand hf sp mep $ rights . M.keys . nodeIdentifiers . nodeInfo+      when (null names) $+        reportAmbiguousErr opts (Left $ NoNameAtPoint target sp)       forM_ names $ \name -> do         case nameSrcSpan name of           RealSrcSpan dsp -> do-            putStrLn $ unwords ["Name", occNameString (nameOccName name),"at",show sp,"is defined at:"]-            reportRefSpans [(fromMaybe (hie_module hf) (nameModule_maybe name)-                            ,(srcSpanStartLine dsp,srcSpanStartCol dsp)-                            ,(srcSpanEndLine dsp, srcSpanEndCol dsp))]+            unless (quiet opts) $+              hPutStrLn stderr $ unwords ["Name", ppName opts (nameOccName name),"at",ppSpan opts sp,"is defined at:"]+            contents <- case nameModule_maybe name of+              Nothing -> pure $ Just $ Right $ hie_hs_src hf+              Just mod+                | mod == hie_module hf -> pure $ Just $ Right $ hie_hs_src hf+                | otherwise -> unsafeInterleaveIO $ do+                    loc <- findOneDef conn (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnitId mod)+                    pure $ case loc of+                      Left _ -> Nothing+                      Right (row:._) -> Just $ Left $ defSrc row++            reportRefSpans opts+              [(fromMaybe (hie_module hf) (nameModule_maybe name)+               ,(srcSpanStartLine dsp,srcSpanStartCol dsp)+               ,(srcSpanEndLine dsp, srcSpanEndCol dsp)+               ,contents+               )]           UnhelpfulSpan msg -> do             case nameModule_maybe name of               Just mod -> do-                (row:.inf) <- reportAmbiguousErr+                (row:.inf) <- reportAmbiguousErr opts                     =<< findOneDef conn (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnitId mod)-                putStrLn $ unwords ["Name", occNameString (nameOccName name),"at",show sp,"is defined at:"]-                reportRefSpans [(mkModule (modInfoUnit inf) (modInfoName inf)-                                ,(defSLine row,defSCol row)-                                ,(defELine row,defECol row))]+                unless (quiet opts) $+                  hPutStrLn stderr $ unwords ["Name", ppName opts (nameOccName name),"at",ppSpan opts sp,"is defined at:"]+                reportRefSpans opts+                  [(mkModule (modInfoUnit inf) (modInfoName inf)+                   ,(defSLine row,defSCol row)+                   ,(defELine row,defECol row)+                   ,Just $ Left $ defSrc row+                   )]               Nothing -> do-                reportAmbiguousErr $ Left $ NameUnhelpfulSpan name (FS.unpackFS msg)-    InfoAtPoint target sp mep -> hieFileCommand conn target $ \hf -> do+                reportAmbiguousErr opts $ Left $ NameUnhelpfulSpan name (FS.unpackFS msg)+    InfoAtPoint target sp mep -> hieFileCommand conn opts target $ \hf -> do       mapM_ (uncurry $ printInfo dynFlags) $ pointCommand hf sp mep $ \ast ->-        (renderHieType dynFlags . flip recoverFullType (hie_types hf) <$> nodeInfo ast, nodeSpan ast)+        (hieTypeToIface . flip recoverFullType (hie_types hf) <$> nodeInfo ast, nodeSpan ast)     RefGraph -> declRefs conn     Dump path -> do       nc <- newIORef =<< makeNc@@ -329,8 +401,14 @@     Html s -> do       nc <- newIORef =<< makeNc       runDbM nc $ html conn s+    GCTypeNames -> do+      start <- offsetTime+      n <- garbageCollectTypeNames conn+      end <- start+      unless (quiet opts) $+        hPutStrLn stderr $ "GCed " ++ show n ++ " types in " <> showDuration end -printInfo :: DynFlags -> NodeInfo String -> RealSrcSpan -> IO ()+printInfo :: DynFlags -> NodeInfo IfaceType -> RealSrcSpan -> IO () printInfo dynFlags x sp = do   putStrLn $ "Span: " ++ showSDoc dynFlags (ppr sp)   putStrLn $ "Constructors: " ++ showSDoc dynFlags (ppr $ nodeAnnotations x)@@ -350,41 +428,104 @@   putStrLn "Types:"   let types = nodeType x   forM_ types $ \typ -> do-    putStrLn typ+    putStrLn $ showSDoc dynFlags (ppr typ)   putStrLn "" -hieFileCommand :: HieDb -> HieTarget -> (HieFile -> IO a) -> IO a-hieFileCommand conn target f = join $ reportAmbiguousErr =<< withTarget conn target f+hieFileCommand :: HieDb -> Options -> HieTarget -> (HieFile -> IO a) -> IO a+hieFileCommand conn opts target f = join $ reportAmbiguousErr opts =<< withTarget conn target f -reportAmbiguousErr :: Either HieDbErr a -> IO a-reportAmbiguousErr (Right x) = return x-reportAmbiguousErr (Left e) = do-  putStrLn $ showHieDbErr e+reportAmbiguousErr :: Options -> Either HieDbErr a -> IO a+reportAmbiguousErr _ (Right x) = return x+reportAmbiguousErr o (Left e) = do+  hPutStrLn stderr $ showHieDbErr o e   exitFailure -showHieDbErr :: HieDbErr -> String-showHieDbErr e = case e of-  NotIndexed mn muid -> unwords ["Module", moduleNameString mn ++ maybe "" (\uid -> "("++show uid++")") muid, "not indexed."]+showHieDbErr :: Options -> HieDbErr -> String+showHieDbErr opts e = case e of+  NoNameAtPoint t spn -> unwords ["No symbols found at",ppSpan opts spn,"in",either id (\(mn,muid) -> ppMod opts mn ++ maybe "" (\uid -> "("++ppUnit opts uid++")") muid) t]+  NotIndexed mn muid -> unwords ["Module", ppMod opts mn ++ maybe "" (\uid -> "("++ppUnit opts uid++")") muid, "not indexed."]   AmbiguousUnitId xs -> unlines $ "UnitId could be any of:" : map ((" - "<>) . unitIdString . modInfoUnit) (toList xs)     <> ["Use --unit-id to disambiguate"]   NameNotFound occ mn muid -> unwords-    ["Couldn't find name:", occNameString occ, maybe "" (("from module " ++) . moduleNameString) mn ++ maybe "" (\uid ->"("++show uid++")") muid]+    ["Couldn't find name:", ppName opts occ, maybe "" (("from module " ++) . moduleNameString) mn ++ maybe "" (\uid ->"("++ppUnit opts uid++")") muid]   NameUnhelpfulSpan nm msg -> unwords     ["Got no helpful spans for:", occNameString (nameOccName nm), "\nMsg:", msg]  -reportRefSpans :: [(Module,(Int,Int),(Int,Int))] -> IO ()-reportRefSpans = traverse_ $ \(mn,(sl,sc),(el,ec)) ->-  putStrLn $ concat-    [ moduleNameString $ moduleName mn-    , ':':show sl-    , ':':show sc-    , '-':show el-    , ':':show ec-    ]+reportRefSpans :: Options -> [(Module,(Int,Int),(Int,Int),Maybe (Either FilePath BS.ByteString))] -> IO ()+reportRefSpans opts xs = do+  nc <- newIORef =<< makeNc+  runDbM nc $ forM_ xs $ \(mn,(sl,sc),(el,ec),hie_f) -> do+      liftIO $ do+        when (colour opts) $+          setSGR [SetUnderlining SingleUnderline]+        putStr $ ppMod opts $ moduleName mn+        when (colour opts) $+          setSGR [SetUnderlining SingleUnderline]+        putStr ":"+        when (colour opts) $+          setSGR [SetUnderlining SingleUnderline]+        putStrLn $ colouredPP Magenta id opts $ concat+          [ show sl+          , ':':show sc+          , '-':show el+          , ':':show ec+          ]+        when (colour opts) $+          setSGR []+      case context opts of+        Nothing -> pure ()+        Just (fromIntegral -> n) -> do+          msrc <- forM hie_f $ \case+            Left loc -> withHieFile loc $ pure . hie_hs_src+            Right src -> pure src+          liftIO $ case msrc of+            Nothing -> putStrLn "<source unavailable>"+            Just src -> do+              let ls = BS.lines src -reportRefs :: [Res RefRow] -> IO ()-reportRefs xs = reportRefSpans-  [ (mdl,(refSLine x, refSCol x),(refELine x, refECol x))+                  (beforeLines',duringLines') = splitAt (sl-1) ls+                  (duringLines,afterLines')   = splitAt (el-sl+1) duringLines'++                  beforeLines = takeEnd n beforeLines'+                  afterLines  = take    n afterLines'++                  (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+                  after  = afterChars <> "\n" <> BS.unlines afterLines++              BS.putStr before+              when (colour opts) $+                setSGR [SetColor Foreground Vivid Red, SetConsoleIntensity BoldIntensity]+              BS.putStr during+              when (colour opts) $+                setSGR []+              BS.putStrLn after++reportRefs :: Options -> [Res RefRow] -> IO ()+reportRefs opts xs = reportRefSpans opts+  [ (mdl,(refSLine x, refSCol x),(refELine x, refECol x),Just $ Left $ refSrc x)   | (x:.inf) <- xs   , let mdl = mkModule (modInfoUnit inf) (modInfoName inf)   ]++colouredPP :: Color -> (a -> String) -> Options -> a -> String+colouredPP c pp opts x = pre <> pp x <> post+  where+    (pre,post)+      | colour opts = (setSGRCode [SetColor Foreground Vivid c], setSGRCode [])+      | otherwise = ("","")+++ppName :: Options -> OccName -> String+ppName = colouredPP Red occNameString++ppMod :: Options -> ModuleName -> String+ppMod = colouredPP Green moduleNameString++ppUnit :: Options -> UnitId -> String+ppUnit = colouredPP Yellow show++ppSpan :: Options -> (Int,Int) -> String+ppSpan = colouredPP Magenta show

@@ -46,6 +46,12 @@ setHieTrace :: HieDb -> Maybe (T.Text -> IO ()) -> IO () setHieTrace = setTrace . getConn +-- | Encodes the original haskell source file of a module, along with whether+-- it is "real" or not+-- A file is "real" if it comes from the user project, as opposed to a+-- dependency+data SourceFile = RealFile FilePath | FakeFile (Maybe FilePath)+ data ModuleInfo   = ModuleInfo   { modInfoName :: ModuleName@@ -55,7 +61,7 @@   , 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)?   , modInfoHash :: Fingerprint -- ^ The hash of the @.hie@ file from which this ModuleInfo was created-  }+  } deriving Eq  instance Show ModuleInfo where   show = show . toRow@@ -115,8 +121,11 @@   = HieModuleRow   { hieModuleHieFile :: FilePath -- ^ Full path to @.hie@ file based on which this row was created   , hieModInfo :: ModuleInfo-  }+  } deriving Eq +instance Show HieModuleRow where+  show = show . toRow+ instance ToRow HieModuleRow where   toRow (HieModuleRow a b) =      toField a : toRow b@@ -227,6 +236,7 @@   = NotIndexed ModuleName (Maybe UnitId)   | AmbiguousUnitId (NonEmpty ModuleInfo)   | NameNotFound OccName (Maybe ModuleName) (Maybe UnitId)+  | NoNameAtPoint HieTarget (Int,Int)   | NameUnhelpfulSpan Name String  data Symbol = Symbol

@@ -1,18 +1,23 @@ module Main where  import GHC.Paths (libdir)-import HieDb (HieDb, HieModuleRow (..), LibDir (..), ModuleInfo (..), withHieDb)-import HieDb.Query (getAllIndexedMods, lookupHieFile, resolveUnitId)+import HieDb (HieDb, HieModuleRow (..), LibDir (..), ModuleInfo (..), withHieDb, withHieFile, addRefsFromLoaded, deleteMissingRealFiles)+import HieDb.Query (getAllIndexedMods, lookupHieFile, resolveUnitId, lookupHieFileFromSource) import HieDb.Run (Command (..), Options (..), runCommand)-import HieDb.Types (HieDbErr (..))+import HieDb.Types (HieDbErr (..), SourceFile(..), runDbM)+import HieDb.Utils (makeNc) import Module (mkModuleName, moduleNameString, stringToUnitId) import System.Directory (findExecutable, getCurrentDirectory, removeDirectoryRecursive) import System.Exit (ExitCode (..), die) import System.FilePath ((</>)) import System.Process (callProcess, proc, readCreateProcessWithExitCode)+import System.IO.Temp+import System.IO import Test.Hspec (Expectation, Spec, afterAll_, around, beforeAll_, describe, hspec, it, runIO,                    shouldBe, shouldEndWith) import Test.Orphans ()+import GHC.Fingerprint+import Data.IORef  main :: IO () main = hspec spec@@ -72,7 +77,51 @@               Nothing -> pure ()               Just _  -> fail "Lookup suceeded unexpectedly" +        describe "deleteMissingRealFiles" $ do+          it "Should delete missing indexed files and nothing else" $ \conn -> do +            originalMods <- getAllIndexedMods conn++            -- Index a new real file, and delete it+            let contents = unlines+                  [ "module Test123 where"+                  , "foobarbaz :: Int"+                  , "foobarbaz = 1"+                  ]+            fp <- withSystemTempFile "Test.hs" $ \fp h -> do+              hPutStr h contents+              hClose h+              callProcess "ghc" $+                "-fno-code" : -- don't produce unnecessary .o and .hi files+                "-fwrite-ide-info" :+                "-hiedir=" <> testTmp :+                [fp]+              let hie_f = testTmp </> "Test123.hie"+              hash <- getFileHash hie_f+              nc <- newIORef =<< makeNc+              runDbM nc $ withHieFile hie_f $+                addRefsFromLoaded conn hie_f (RealFile fp) hash+              pure fp++            -- Check that it was indexed+            before <- lookupHieFileFromSource conn fp+            case before of+              Nothing -> fail $ "File "<> show fp <> "wasn't indexed"+              Just _ -> pure ()++            deleteMissingRealFiles conn++            -- Check that it was deleted from the db+            after <- lookupHieFileFromSource conn fp+            case after of+              Nothing -> pure ()+              Just _ -> fail $ "deleteMissingRealFiles didn't delete file: " <> show fp++            -- Check that the other modules are still indexed+            afterMods <- getAllIndexedMods conn+            originalMods `shouldBe` afterMods++ cliSpec :: Spec cliSpec =   -- TODO commands not covered: init, type-refs, ref-graph, dump, reachable, unreachable, html@@ -104,40 +153,43 @@       it "list references at given point" $         runHieDbCli ["point-refs", "Module1", "13", "2"]           `suceedsWithStdin` unlines-            [ "Name function2 at (13,2) is used in:"-            , "Module1:3:7-3:16"+            [ "Module1:3:7-3:16"             , "Module1:12:1-12:10"             , "Module1:13:1-13:10"             ]      describe "point-types" $ do-      it "list references at point when there's Type" $-        runHieDbCli ["point-refs", "Module1", "8", "21"]+      it "Prints types of symbol under cursor" $+        runHieDbCli ["point-types", "Module1", "10", "10" ]           `suceedsWithStdin` unlines-            [ "Name String at (8,21) is used in:"-            , "Sub.Module2:6:19-6:25"-            , "Module1:8:21-8:27"+            [ "Int -> Bool" {- types of `even` function under cursor -}+            , "forall a. Integral a => a -> Bool"             ]-      it "Give no output at point when there's not Type" $-        runHieDbCli ["point-refs", "Module1", "7", "1"]-          `suceedsWithStdin` ""-+      it "Fails for symbols that don't have type associated" $ do+        (exitCode, actualStdout, actualStderr) <- runHieDbCli ["point-types", "Module1", "8", "21"]+        actualStdout `shouldBe` ""+        exitCode `shouldBe` ExitFailure 1+        actualStderr `shouldBe` "No symbols found at (8,21) in Module1\n"+             describe "point-defs" $ do       it "outputs the location of symbol when definition site can be found is indexed" $         runHieDbCli ["point-defs", "Module1", "13", "29"]           `suceedsWithStdin` unlines-            [ "Name showInt at (13,29) is defined at:"-            , "Sub.Module2:7:1-7:8"+            [ "Sub.Module2:7:1-7:8"             ]-      it "suceeds with no output when there's no symbol at given point" $-        runHieDbCli ["point-defs", "Module1", "13", "13"]-          `suceedsWithStdin` ""+      it "Fails with informative error message when there's no symbol at given point" $ do+        (exitCode, actualStdout, actualStderr) <- runHieDbCli ["point-defs", "Module1", "13", "13"]+        actualStdout `shouldBe` ""+        exitCode `shouldBe` ExitFailure 1+        actualStderr `shouldBe` "No symbols found at (13,13) in Module1\n"+       it "fails with informative error message when the difinition can't be found" $ do-        (exitCode, actualStdout, _) <- runHieDbCli ["point-defs", "Module1", "13", "24"]+        (exitCode, actualStdout, actualStderr) <- runHieDbCli ["point-defs", "Module1", "13", "24"]+        actualStdout `shouldBe` ""         exitCode `shouldBe` ExitFailure 1-        actualStdout `shouldBe` "Couldn't find name: $ from module GHC.Base(base)\n"+        actualStderr `shouldBe` "Couldn't find name: $ from module GHC.Base(base)\n" -    describe "point-info" $+    describe "point-info" $ do       it "gives information about symbol at specified location" $         runHieDbCli ["point-info", "Sub.Module2", "10", "10"]           `suceedsWithStdin` unlines@@ -149,6 +201,20 @@             , "    IdentifierDetails Nothing {Decl ConDec (Just SrcSpanOneLine \"test/data/Sub/Module2.hs\" 10 7 24)}"             , "Types:\n"             ]+      it "correctly prints type signatures" $+        runHieDbCli ["point-info", "Module1", "10", "10"]+          `suceedsWithStdin` unlines+            [ "Span: test/data/Module1.hs:10:8-11"+            , "Constructors: {(HsVar, HsExpr), (HsWrap, HsExpr)}"+            , "Identifiers:"+            , "Symbol:v:even:GHC.Real:base"+            , "even defined at <no location info>"+            , "    IdentifierDetails Just forall a. Integral a => a -> Bool {Use}"+            , "Types:"+            , "Int -> Bool"+            , "forall a. Integral a => a -> Bool"+            , ""+            ]      describe "name-def" $       it "lookup definition of name" $@@ -194,9 +260,8 @@  suceedsWithStdin :: IO (ExitCode, String, String) -> String -> Expectation suceedsWithStdin action expectedStdin = do-  (exitCode, actualStdin, actualStdErr) <- action+  (exitCode, actualStdin, _actualStdErr) <- action   exitCode `shouldBe` ExitSuccess-  actualStdErr `shouldBe` ""   actualStdin `shouldBe` expectedStdin  @@ -249,5 +314,8 @@   { database = testDb   , trace = False   , quiet = True-  , virtualFile = False+  , colour = False+  , context = Nothing+  , reindex = False+  , keepMissing = False   }