diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 `. This will generate `.hie` files and save them in `` + +### Indexing + +``` +$ hiedb -D index +``` + +You can omit ``, 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 name-refs [MODULE] + ``` +- Looking up references for a type: + ``` + $ hiedb -D type-refs [MODULE] + ``` + +`MODULE` is the module the name was originaly defined in. + +- Looking up references for a symbol at a particular location: + ``` + $ hiedb -D - point-refs (-f|--hiefile HIEFILE) SLINE SCOL [ELINE] [ECOL] + $ hiedb -D - 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. 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.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 diff --git a/src/HieDb/Create.hs b/src/HieDb/Create.hs --- a/src/HieDb/Create.hs +++ b/src/HieDb/Create.hs @@ -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) diff --git a/src/HieDb/Run.hs b/src/HieDb/Run.hs --- a/src/HieDb/Run.hs +++ b/src/HieDb/Run.hs @@ -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 "" + 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 diff --git a/src/HieDb/Types.hs b/src/HieDb/Types.hs --- a/src/HieDb/Types.hs +++ b/src/HieDb/Types.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 " + , " 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 }