diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,16 +1,33 @@ # Revision history for hiedb +## 0.6.0.0 -- 2024-02-11 + +* Add index on column `unit` of table `mods` +* Add new table `imports` which indexes import statements +* Add new cli options that allow selectively skipping indexing of some things: + `--skip-refs` Skip refs table when indexing + `--skip-decls` Skip decls table when indexing + `--skip-defs` Skip defs table when indexing + `--skip-exports` Skip exports table when indexing + `--skip-imports` Skip imports table when indexing + `--skip-types` Skip types and typerefs table when indexing + `--skip-typerefs` Skip typerefs table when indexing +* Fix a bug where duplicate entries were inserted into `typerefs` table during indexing +* Fix a bug in `searchDef` query which was mistakenly not including ':' when searching by occurrence names + ## 0.5.0.1 -- 2024-01-12 -- Fix incorrect Show Symbol instance in 0.5.0.0 +* Fix incorrect Show Symbol instance in 0.5.0.0 ## 0.5.0.0 -- 2024-01-12 -- Handle duplicate record fields in GHC 9.8 instead of crashing +* Handle duplicate record fields in GHC 9.8 instead of crashing ## 0.4.4.0 -- 2023-11-13 + * Add `--src-base-dir` option allowing for src file indexing in `mods` -* 9.8.1 support +* Support GHC 9.8.1 +* Drop support for GHC 8.10 * Add `lookupHieFileFromHash` * Add `lookupPackage` * Add `removeDependencySrcFiles` 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.5.0.1 +version: 0.6.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,15 +10,17 @@ maintainer: zubin.duggal@gmail.com copyright: Zubin Duggal category: Development -extra-source-files: - CHANGELOG.md +extra-doc-files: README.md + CHANGELOG.md +extra-source-files: test/data/*.hs test/data/Sub/*.hs -tested-with: GHC ==8.8.1 || ==8.8.2 || ==8.8.3 || ==8.8.4 - || ==8.10.1 || ==8.10.2 || ==8.10.3 || ==8.10.4 - || ==9.0.1 - +tested-with: GHC ==9.0.2 + || ==9.2.8 + || ==9.4.8 + || ==9.6.4 + || ==9.8.1 source-repository head type: git @@ -28,13 +30,15 @@ default-language: Haskell2010 build-depends: base >= 4.12 && < 4.20 ghc-options: -Wall - -Wincomplete-uni-patterns - -Wincomplete-record-updates -Wcompat -Widentities - -Wredundant-constraints + -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wpartial-fields - -Wno-unrecognised-pragmas + -Wredundant-constraints + -Wunused-packages + -Wno-name-shadowing + executable hiedb import: common-options hs-source-dirs: exe @@ -81,7 +85,6 @@ build-tool-depends: hiedb:hiedb build-depends: directory , filepath - , ghc >= 8.6 , ghc-paths , hiedb , hspec diff --git a/src/HieDb/Compat.hs b/src/HieDb/Compat.hs --- a/src/HieDb/Compat.hs +++ b/src/HieDb/Compat.hs @@ -25,7 +25,11 @@ , mkVarOccFS , Name , nameSrcSpan +#if __GLASGOW_HASKELL__ >= 903 + , NameCacheUpdater +#else , NameCacheUpdater(..) +#endif , NameCache , nsNames , initNameCache @@ -88,7 +92,6 @@ import Compat.HieTypes -#if __GLASGOW_HASKELL__ >= 900 import GHC.Data.FastString as FS import GHC.Driver.Session import GHC.Iface.Env @@ -114,33 +117,15 @@ #else import GHC.Utils.Outputable (showSDoc, ppr, (<+>), hang, text) #endif -#else -import DynFlags -import FastString -import Fingerprint -import FieldLabel -import Module -import Name -import NameCache -import Outputable (showSDoc, ppr, (<+>), hang, text) -#if __GLASGOW_HASKELL__ < 903 -import IfaceEnv (NameCacheUpdater(..)) -#endif -import IfaceType -import UniqSupply -import SrcLoc -import SysTools -import qualified Avail -#endif -#if __GLASGOW_HASKELL__ >= 900 +import qualified Algebra.Graph.AdjacencyMap as Graph +import qualified Algebra.Graph.AdjacencyMap.Algorithm as Graph + import GHC.Types.SrcLoc import Compat.HieUtils import qualified Data.Map as M import qualified Data.Set as S -import qualified Algebra.Graph.AdjacencyMap as Graph -import qualified Algebra.Graph.AdjacencyMap.Algorithm as Graph -- nodeInfo' :: Ord a => HieAST a -> NodeInfo a @@ -158,22 +143,7 @@ GT -> b : mergeSorted la bs mergeSorted as [] = as mergeSorted [] bs = bs -#else -import qualified FastString as FS -nodeInfo' :: HieAST TypeIndex -> NodeInfo TypeIndex -nodeInfo' = nodeInfo -type Unit = UnitId -unitString :: Unit -> String -unitString = unitIdString -stringToUnit :: String -> Unit -stringToUnit = stringToUnitId -moduleUnit :: Module -> Unit -moduleUnit = moduleUnitId -unhelpfulSpanFS :: FS.FastString -> FS.FastString -unhelpfulSpanFS = id -#endif - #if __GLASGOW_HASKELL__ < 902 type HiePath = FastString #endif @@ -238,8 +208,9 @@ -- This is horrible, we can improve it once -- https://gitlab.haskell.org/ghc/ghc/-/issues/24244 is addressed fieldNameSpace_maybe ns = fieldOcc_maybe (mkOccName ns "") -#endif +#else fieldNameSpace_maybe _ = Nothing +#endif #if __GLASGOW_HASKELL__ < 907 fieldName :: FastString -> NameSpace diff --git a/src/HieDb/Create.hs b/src/HieDb/Create.hs --- a/src/HieDb/Create.hs +++ b/src/HieDb/Create.hs @@ -16,9 +16,11 @@ import Control.Exception import Control.Monad import Control.Monad.IO.Class +import Control.Monad.State.Strict (evalStateT) import qualified Data.Array as A import qualified Data.Map as M +import qualified Data.IntMap.Strict as IMap import Data.Int import Data.List ( isSuffixOf ) @@ -35,7 +37,7 @@ import HieDb.Utils sCHEMA_VERSION :: Integer -sCHEMA_VERSION = 7 +sCHEMA_VERSION = 8 dB_VERSION :: Integer dB_VERSION = read (show sCHEMA_VERSION ++ "999" ++ show hieVersion) @@ -91,6 +93,7 @@ \, CONSTRAINT real_has_src CHECK ( (NOT is_real) OR (hs_src IS NOT NULL) ) \ \)" execute_ conn "CREATE INDEX IF NOT EXISTS mod_hash ON mods(hieFile,hash)" + execute_ conn "CREATE INDEX IF NOT EXISTS mod_unit ON mods(unit)" execute_ conn "CREATE TABLE IF NOT EXISTS exports \ \( hieFile TEXT NOT NULL \ @@ -130,6 +133,19 @@ \)" execute_ conn "CREATE INDEX IF NOT EXISTS decls_mod ON decls(hieFile)" + execute_ conn "CREATE TABLE IF NOT EXISTS imports \ + \( hieFile TEXT NOT NULL \ + \, mod TEXT NOT NULL \ + \, sl INTEGER NOT NULL \ + \, sc INTEGER NOT NULL \ + \, el INTEGER NOT NULL \ + \, ec INTEGER NOT NULL \ + \, FOREIGN KEY(hieFile) REFERENCES mods(hieFile) ON UPDATE CASCADE ON DELETE CASCADE DEFERRABLE INITIALLY DEFERRED \ + \)" + execute_ conn "CREATE INDEX IF NOT EXISTS imports_mod ON imports(mod)" + execute_ conn "CREATE INDEX IF NOT EXISTS imports_hiefile ON imports(hieFile)" + + execute_ conn "CREATE TABLE IF NOT EXISTS defs \ \( hieFile TEXT NOT NULL \ \, occ TEXT NOT NULL \ @@ -183,7 +199,7 @@ mod = moduleName m uid = moduleUnit m execute conn "INSERT INTO typenames(name,mod,unit) VALUES (?,?,?)" (occ,mod,uid) - Just . fromOnly . head <$> query conn "SELECT id FROM typenames WHERE name = ? AND mod = ? AND unit = ?" (occ,mod,uid) + fmap fromOnly . listToMaybe <$> query conn "SELECT id FROM typenames WHERE name = ? AND mod = ? AND unit = ?" (occ,mod,uid) {-| Add references to types from given @.hie@ file to DB. -} addTypeRefs @@ -200,19 +216,47 @@ asts = getAsts $ hie_asts hf addTypesFromAst :: HieAST TypeIndex -> IO () addTypesFromAst ast = do - mapM_ (addTypeRef db path arr ixs (nodeSpan ast)) - $ mapMaybe (\x -> guard (any (not . isOccurrence) (identInfo x)) *> identType x) + flip evalStateT IMap.empty + $ mapM_ (addTypeRef db path arr ixs (nodeSpan ast)) + $ mapMaybe (\x -> guard (not (all isOccurrence (identInfo x))) *> identType x) $ M.elems $ nodeIdentifiers $ nodeInfo' ast mapM_ addTypesFromAst $ nodeChildren ast +-- | Options to skip indexing phases +data SkipOptions = + SkipOptions + { skipRefs :: Bool + , skipDecls :: Bool + , skipDefs :: Bool + , skipExports :: Bool + , skipImports :: Bool + , skipTypes :: Bool + -- ^ Note skip types will also skip type refs since it is dependent + , skipTypeRefs :: Bool + } + deriving Show + +defaultSkipOptions :: SkipOptions +defaultSkipOptions = + SkipOptions + { skipRefs = False + , skipDecls = False + , skipDefs = False + , skipExports = False + , skipImports = False + , skipTypes = False + -- ^ Note skip types will also skip type refs since it is dependent + , skipTypeRefs = False + } + {-| 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 -> Maybe FilePath -> FilePath -> m Bool -addRefsFrom c@(getConn -> conn) mSrcBaseDir path = do +addRefsFrom :: (MonadIO m, NameCacheMonad m) => HieDb -> Maybe FilePath -> SkipOptions -> FilePath -> m Bool +addRefsFrom c@(getConn -> conn) mSrcBaseDir skipOptions path = do hash <- liftIO $ getFileHash path mods <- liftIO $ query conn "SELECT * FROM mods WHERE hieFile = ? AND hash = ?" (path, hash) case mods of @@ -229,10 +273,10 @@ (\srcBaseDir -> do srcFullPath <- makeAbsolute (srcBaseDir hie_hs_file hieFile) fileExists <- doesFileExist srcFullPath - pure $ if fileExists then RealFile srcFullPath else (FakeFile Nothing) + pure $ if fileExists then RealFile srcFullPath else FakeFile Nothing ) mSrcBaseDir - addRefsFromLoaded c path srcfile hash hieFile + addRefsFromLoadedInternal c path srcfile hash skipOptions hieFile addRefsFromLoaded :: MonadIO m @@ -244,11 +288,25 @@ -> Fingerprint -- ^ The hash of the @.hie@ file -> HieFile -- ^ Data loaded from the @.hie@ file -> m () -addRefsFromLoaded - db@(getConn -> conn) path sourceFile hash hf = +addRefsFromLoaded db path sourceFile hash hf = + addRefsFromLoadedInternal db path sourceFile hash defaultSkipOptions hf + +addRefsFromLoadedInternal + :: MonadIO m + => HieDb -- ^ HieDb into which we're adding the file + -> FilePath -- ^ Path to @.hie@ file + -> 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 + -> SkipOptions -- ^ Skip indexing certain tables + -> HieFile -- ^ Data loaded from the @.hie@ file + -> m () +addRefsFromLoadedInternal + db@(getConn -> conn) path sourceFile hash skipOptions hf = liftIO $ withTransaction conn $ do deleteInternalTables conn path - addRefsFromLoaded_unsafe db path sourceFile hash hf + addRefsFromLoaded_unsafe db path sourceFile hash skipOptions hf -- | Like 'addRefsFromLoaded' but without: -- 1) using a transaction @@ -263,10 +321,11 @@ -- 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 + -> SkipOptions -- ^ Skip indexing certain tables -> HieFile -- ^ Data loaded from the @.hie@ file -> m () addRefsFromLoaded_unsafe - db@(getConn -> conn) path sourceFile hash hf = liftIO $ do + db@(getConn -> conn) path sourceFile hash skipOptions hf = liftIO $ do let isBoot = "boot" `isSuffixOf` path mod = moduleName smod @@ -280,19 +339,28 @@ execute conn "INSERT INTO mods VALUES (?,?,?,?,?,?,?)" modrow - let (rows,decls) = genRefsAndDecls path smod refmap - executeMany conn "INSERT INTO refs VALUES (?,?,?,?,?,?,?,?)" rows - executeMany conn "INSERT INTO decls VALUES (?,?,?,?,?,?,?)" decls + let AstInfo rows decls imports = genAstInfo path smod refmap + unless (skipRefs skipOptions) $ + executeMany conn "INSERT INTO refs VALUES (?,?,?,?,?,?,?,?)" rows + unless (skipDecls skipOptions) $ + executeMany conn "INSERT INTO decls VALUES (?,?,?,?,?,?,?)" decls + unless (skipImports skipOptions) $ + executeMany conn "INSERT INTO imports VALUES (?,?,?,?,?,?)" imports + let defs = genDefRow path smod refmap - forM defs $ \def -> do - execute conn "INSERT INTO defs VALUES (?,?,?,?,?,?)" def + unless (skipDefs skipOptions) $ + forM_ defs $ \def -> + execute conn "INSERT INTO defs VALUES (?,?,?,?,?,?)" def let exports = generateExports path $ hie_exports hf - executeMany conn "INSERT INTO exports VALUES (?,?,?,?,?,?,?,?)" exports + unless (skipExports skipOptions) $ + executeMany conn "INSERT INTO exports VALUES (?,?,?,?,?,?,?,?)" exports - ixs <- addArr db (hie_types hf) - addTypeRefs db path hf ixs + unless (skipTypes skipOptions) $ do + ixs <- addArr db (hie_types hf) + unless (skipTypeRefs skipOptions) $ do + 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 @@ -40,7 +40,7 @@ getAllIndexedMods (getConn -> conn) = query_ conn "SELECT * FROM mods" {-| List all module exports -} -getAllIndexedExports :: HieDb -> IO [(ExportRow)] +getAllIndexedExports :: HieDb -> IO [ExportRow] getAllIndexedExports (getConn -> conn) = query_ conn "SELECT * FROM exports" {-| List all exports of the given module -} @@ -152,7 +152,7 @@ = 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++"%") + \LIMIT 200" (Only $ '_':':':cs++"%") {-| @withTarget db t f@ runs function @f@ with HieFile specified by HieTarget @t@. In case the target is given by ModuleName (and optionally Unit) it is first resolved diff --git a/src/HieDb/Run.hs b/src/HieDb/Run.hs --- a/src/HieDb/Run.hs +++ b/src/HieDb/Run.hs @@ -5,6 +5,7 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ApplicativeDo #-} module HieDb.Run where import Prelude hiding (mod) @@ -80,6 +81,7 @@ , reindex :: Bool , keepMissing :: Bool , srcBaseDir :: Maybe FilePath + , skipIndexingOptions :: SkipOptions } data Command @@ -127,10 +129,28 @@ <*> switch (long "reindex" <> short 'r' <> help "Re-index all files in database before running command, deleting those with missing '.hie' files") <*> switch (long "keep-missing" <> help "Keep missing files when re-indexing") <*> optional (strOption (long "src-base-dir" <> help "Provide a base directory to index src files as real files")) + <*> skipFlags 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 + skipFlags = do + refs <- switch (long "skip-refs" <> help "Skip refs table when indexing") + decls <- switch (long "skip-decls" <> help "Skip decls table when indexing") + defs <- switch (long "skip-defs" <> help "Skip defs table when indexing") + exports <- switch (long "skip-exports" <> help "Skip exports table when indexing") + imports <- switch (long "skip-imports" <> help "Skip imports table when indexing") + types <- switch (long "skip-types" <> help "Skip types and typerefs table when indexing") + typeRefs <- switch (long "skip-typerefs" <> help "Skip typerefs table when indexing") + pure $ SkipOptions + { skipRefs = refs + , skipDecls = decls + , skipDefs = defs + , skipExports = exports + , skipImports = imports + , skipTypes = types + , skipTypeRefs = typeRefs + } cmdParser :: Parser Command cmdParser @@ -222,7 +242,7 @@ Just w -> do hPutStr hndl $ replicate w ' ' hPutStr hndl "\r" - pure $ take (w-8) $ msg' + pure $ take (w-8) msg' liftIO $ hPutStr hndl msg x <- act f if x @@ -238,7 +258,7 @@ istart <- offsetTime (length -> done, length -> skipped)<- runDbM nc $ partition id <$> - zipWithM (\f n -> progress' h (length files) n (addRefsFrom conn (srcBaseDir opts)) f) files [0..] + zipWithM (\f n -> progress' h (length files) n (addRefsFrom conn (srcBaseDir opts) (skipIndexingOptions opts)) f) files [0..] indexTime <- istart start <- offsetTime @@ -372,11 +392,7 @@ reportAmbiguousErr opts (Left $ NoNameAtPoint target sp) forM_ names $ \name -> do case nameSrcSpan name of -#if __GLASGOW_HASKELL__ >= 900 RealSrcSpan dsp _ -> do -#else - RealSrcSpan dsp -> do -#endif unless (quiet opts) $ hPutStrLn stderr $ unwords ["Name", ppName opts (nameOccName name),"at",ppSpan opts sp,"is defined at:"] contents <- case nameModule_maybe name of @@ -510,7 +526,7 @@ beforeLines = takeEnd n beforeLines' afterLines = take n afterLines' - (beforeChars,during') = BS.splitAt (sc-1) $ BS.concat $ intersperse "\n" $ duringLines + (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 diff --git a/src/HieDb/Types.hs b/src/HieDb/Types.hs --- a/src/HieDb/Types.hs +++ b/src/HieDb/Types.hs @@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE BlockArguments #-} @@ -178,6 +177,25 @@ instance FromRow DeclRow where fromRow = DeclRow <$> field <*> field <*> field <*> field <*> field <*> field <*> field + +data ImportRow + = ImportRow + { importSrc :: FilePath + , importModuleName :: ModuleName + , importSLine :: Int + , importSCol :: Int + , importELine :: Int + , importECol :: Int + } + +instance FromRow ImportRow where + fromRow = + ImportRow + <$> field <*> field <*> field <*> field + <*> field <*> field + +instance ToRow ImportRow where + toRow (ImportRow a b c d e f) = toRow ((a,b,c,d):.(e,f)) data TypeName = TypeName { typeName :: OccName diff --git a/src/HieDb/Utils.hs b/src/HieDb/Utils.hs --- a/src/HieDb/Utils.hs +++ b/src/HieDb/Utils.hs @@ -5,7 +5,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE CPP #-} module HieDb.Utils where @@ -19,13 +18,11 @@ import qualified Compat.HieTypes as HieTypes import Compat.HieUtils import qualified Data.Map as M - +import qualified Data.Set as S import System.Directory import System.FilePath -import Control.Arrow ( (&&&) ) -import Data.Bifunctor ( bimap ) import Data.List (find) import Control.Monad.IO.Class import qualified Data.Array as A @@ -39,40 +36,59 @@ import HieDb.Types import HieDb.Compat import Database.SQLite.Simple -import Control.Concurrent +import Control.Monad.State.Strict (StateT, get, put) +import qualified Data.IntSet as ISet +import qualified Data.IntMap.Strict as IMap +import Data.IntMap.Strict (IntMap) +import Data.IntSet (IntSet) +import Control.Monad (guard, unless) -addTypeRef :: HieDb -> FilePath -> A.Array TypeIndex HieTypeFlat -> A.Array TypeIndex (Maybe Int64) -> RealSrcSpan -> TypeIndex -> IO () +#if __GLASGOW_HASKELL__ >= 903 +import Control.Concurrent.MVar (readMVar) +#endif + +-- Each AST Node can have a lot of repetitive type information, +-- esp. when deriving is involved. +-- This StateT state keeps track of which types in AST we already indexed +-- to avoid having repeated (Depth, Type) inserted under the same RealSrcSpan. +-- +-- This `IntMap IntSet` is morally `Map Depth (Set TypeIndex)` mapping +-- the depth (of a type within tree structure of types - ends up as typerefs.depth) +-- to a list of type IDs (identifiers of types assigned as id within typenames table) +-- that we already indexed. +type TypeIndexing a = StateT (IntMap IntSet) IO a + +addTypeRef :: HieDb -> FilePath -> A.Array TypeIndex HieTypeFlat -> A.Array TypeIndex (Maybe Int64) -> RealSrcSpan -> TypeIndex -> TypeIndexing () addTypeRef (getConn -> conn) hf arr ixs sp = go 0 where sl = srcSpanStartLine sp sc = srcSpanStartCol sp el = srcSpanEndLine sp ec = srcSpanEndCol sp - go :: TypeIndex -> Int -> IO () - go d i = do + go :: Int -> TypeIndex -> TypeIndexing () + go depth i = do case ixs A.! i of Nothing -> pure () Just occ -> do - let ref = TypeRef occ hf d sl sc el ec - execute conn "INSERT INTO typerefs VALUES (?,?,?,?,?,?,?)" ref - let next = go (d+1) + let ref = TypeRef occ hf depth sl sc el ec + indexed <- get + let isTypeIndexed = ISet.member (fromIntegral occ) (IMap.findWithDefault ISet.empty depth indexed) + unless isTypeIndexed $ do + liftIO $ execute conn "INSERT INTO typerefs VALUES (?,?,?,?,?,?,?)" ref + put $ IMap.alter (\case + Nothing -> Just $ ISet.singleton (fromIntegral occ) + Just s -> Just $ ISet.insert (fromIntegral occ) s + ) depth indexed + let next = go (depth + 1) case arr A.! i of HTyVarTy _ -> pure () -#if __GLASGOW_HASKELL__ >= 808 HAppTy x (HieArgs xs) -> mapM_ next (x:map snd xs) -#else - HAppTy x y -> mapM_ next [x,y] -#endif HTyConApp _ (HieArgs xs) -> mapM_ (next . snd) xs HForAllTy ((_ , a),_) b -> mapM_ next [a,b] -#if __GLASGOW_HASKELL__ >= 900 HFunTy a b c -> mapM_ next [a,b,c] -#else - HFunTy a b -> mapM_ next [a,b] -#endif HQualTy a b -> mapM_ next [a,b] HLitTy _ -> pure () - HCastTy a -> go d a + HCastTy a -> go depth a HCoercionTy -> pure () makeNc :: IO NameCache @@ -122,11 +138,7 @@ #endif return $ case lookupOrigNameCache nsns mdl occ of Just name -> case nameSrcSpan name of -#if __GLASGOW_HASKELL__ >= 900 RealSrcSpan sp _ -> Right (sp, mdl) -#else - RealSrcSpan sp -> Right (sp, mdl) -#endif UnhelpfulSpan msg -> Left $ NameUnhelpfulSpan name (unpackFS $ unhelpfulSpanFS msg) Nothing -> Left $ NameNotFound occ (Just $ moduleName mdl) (Just $ moduleUnit mdl) @@ -143,18 +155,10 @@ dynFlagsForPrinting :: LibDir -> IO DynFlags dynFlagsForPrinting (LibDir libdir) = do - systemSettings <- initSysTools -#if __GLASGOW_HASKELL__ >= 808 - libdir -#else - (Just libdir) -#endif -#if __GLASGOW_HASKELL__ >= 905 + systemSettings <- initSysTools libdir return $ defaultDynFlags systemSettings -#elif __GLASGOW_HASKELL__ >= 810 - return $ defaultDynFlags systemSettings $ LlvmConfig [] [] -#else - return $ defaultDynFlags systemSettings ([], []) +#if __GLASGOW_HASKELL__ < 905 + (LlvmConfig [] []) #endif isCons :: String -> Bool @@ -162,13 +166,28 @@ isCons (x:_) | isUpper x = True isCons _ = False -genRefsAndDecls :: FilePath -> Module -> M.Map Identifier [(Span, IdentifierDetails a)] -> ([RefRow],[DeclRow]) -genRefsAndDecls path smdl refmap = genRows $ flat $ M.toList refmap +data AstInfo = + AstInfo + { astInfoRefs :: [RefRow] + , astInfoDecls :: [DeclRow] + , astInfoImports :: [ImportRow] + } + +instance Semigroup AstInfo where + AstInfo r1 d1 i1 <> AstInfo r2 d2 i2 = AstInfo (r1 <> r2) (d1 <> d2) (i1 <> i2) + +instance Monoid AstInfo where + mempty = AstInfo [] [] [] + +genAstInfo :: FilePath -> Module -> M.Map Identifier [(Span, IdentifierDetails a)] -> AstInfo +genAstInfo path smdl refmap = genRows $ flat $ M.toList refmap where flat = concatMap (\(a,xs) -> map (a,) xs) genRows = foldMap go - go = bimap maybeToList maybeToList . (goRef &&& goDec) + go = mkAstInfo + mkAstInfo x = AstInfo (maybeToList $ goRef x) (maybeToList $ goDec x) (maybeToList $ goImport x) + goRef (Right name, (sp,_)) | Just mod <- nameModule_maybe name = Just $ RefRow path occ (moduleName mod) (moduleUnit mod) sl sc el ec @@ -180,6 +199,16 @@ ec = srcSpanEndCol sp goRef _ = Nothing + goImport (Left modName, (sp, IdentifierDetails _ contextInfos)) = do + _ <- guard $ not $ S.disjoint contextInfos $ S.fromList [IEThing Import, IEThing ImportAs, IEThing ImportHiding] + let + sl = srcSpanStartLine sp + sc = srcSpanStartCol sp + el = srcSpanEndLine sp + ec = srcSpanEndCol sp + Just $ ImportRow path modName sl sc el ec + goImport _ = Nothing + goDec (Right name,(_,dets)) | Just mod <- nameModule_maybe name , mod == smdl @@ -211,11 +240,7 @@ where genRows = mapMaybe go getSpan name dets -#if __GLASGOW_HASKELL__ >= 900 | RealSrcSpan sp _ <- nameSrcSpan name = Just sp -#else - | RealSrcSpan sp <- nameSrcSpan name = Just sp -#endif | otherwise = do (sp, _dets) <- find defSpan dets pure sp diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -2,7 +2,7 @@ module Main where import GHC.Paths (libdir, ghc) -import HieDb (HieDb, HieModuleRow (..), LibDir (..), ModuleInfo (..), withHieDb, withHieFile, addRefsFromLoaded, deleteMissingRealFiles) +import HieDb (HieDb, HieModuleRow (..), LibDir (..), ModuleInfo (..), withHieDb, withHieFile, addRefsFromLoaded, deleteMissingRealFiles, defaultSkipOptions) import HieDb.Query (getAllIndexedMods, lookupHieFile, resolveUnitId, lookupHieFileFromSource) import HieDb.Run (Command (..), Options (..), runCommand) import HieDb.Types (HieDbErr (..), SourceFile(..), runDbM) @@ -88,6 +88,7 @@ -- Index a new real file, and delete it let contents = unlines [ "module Test123 where" + , "import Prelude" , "foobarbaz :: Int" , "foobarbaz = 1" ] @@ -124,7 +125,6 @@ afterMods <- getAllIndexedMods conn originalMods `shouldBe` afterMods - cliSpec :: Spec cliSpec = -- TODO commands not covered: init, type-refs, ref-graph, dump, reachable, unreachable, html @@ -143,7 +143,7 @@ ] (exitCode, actualStdin, _actualStdErr) <- runHieDbCli ["ls"] exitCode `shouldBe` ExitSuccess - (sort $ lines actualStdin) `shouldBe` (sort expectedOutput) + sort (lines actualStdin) `shouldBe` sort expectedOutput describe "name-refs" $ it "lists all references of given function" $ do @@ -167,8 +167,7 @@ it "Prints types of symbol under cursor" $ runHieDbCli ["point-types", "Module1", "10", "10" ] `succeedsWithStdin` unlines - [ "Int -> Bool" {- types of `even` function under cursor -} - , "forall a. Integral a => a -> Bool" + [ "Bool -> Bool" {- type of `not` function under cursor -} ] it "Fails for symbols that don't have type associated" $ do (exitCode, actualStdout, actualStderr) <- runHieDbCli ["point-types", "Module1", "8", "21"] @@ -201,56 +200,22 @@ [ "Span: test/data/Sub/Module2.hs:11:7-23" , "Constructors: {(ConDeclH98, ConDecl)}" , "Identifiers:" - , "Symbol:c::Data1Constructor1:Sub.Module2:main" + , "Symbol:c:Data1Constructor1:Sub.Module2:main" , "Data1Constructor1 defined at test/data/Sub/Module2.hs:11:7-23" -#if __GLASGOW_HASKELL__ >= 900 , " Details: Nothing {declaration of constructor bound at: test/data/Sub/Module2.hs:11:7-23}" -#else - , " IdentifierDetails Nothing {Decl ConDec (Just SrcSpanOneLine \"test/data/Sub/Module2.hs\" 11 7 24)}" -#endif , "Types:\n" ] it "correctly prints type signatures" $ runHieDbCli ["point-info", "Module1", "10", "10"] `succeedsWithStdin` unlines -#if __GLASGOW_HASKELL__ >= 904 - [ "Span: test/data/Module1.hs:10:8-11" - , "Constructors: {(HsVar, HsExpr), (XExpr, HsExpr)}" - , "Identifiers:" - , "$dIntegral defined at " - , " Details: Just Integral Int {usage of evidence variable}" - , "Symbol:v::even:GHC.Real:base" - , "even defined at " - , " Details: Just forall a. Integral a => a -> Bool {usage}" -#elif __GLASGOW_HASKELL__ >= 902 - [ "Span: test/data/Module1.hs:10:8-11" - , "Constructors: {(XExpr, HsExpr), (HsVar, HsExpr)}" - , "Identifiers:" - , "Symbol:v::even:GHC.Real:base" - , "even defined at " - , " Details: Just forall a. Integral a => a -> Bool {usage}" - , "$dIntegral defined at " - , " Details: Just Integral Int {usage of evidence variable}" -#elif __GLASGOW_HASKELL__ >= 900 - [ "Span: test/data/Module1.hs:10:8-11" - , "Constructors: {(HsVar, HsExpr), (XExpr, HsExpr)}" - , "Identifiers:" - , "Symbol:v::even:GHC.Real:base" - , "even defined at " - , " Details: Just forall a. Integral a => a -> Bool {usage}" - , "$dIntegral defined at " - , " Details: Just Integral Int {usage of evidence variable}" -#else - [ "Span: test/data/Module1.hs:10:8-11" - , "Constructors: {(HsVar, HsExpr), (HsWrap, HsExpr)}" + [ "Span: test/data/Module1.hs:10:8-10" + , "Constructors: {(HsVar, HsExpr)}" , "Identifiers:" - , "Symbol:v::even:GHC.Real:base" - , "even defined at " - , " IdentifierDetails Just forall a. Integral a => a -> Bool {Use}" -#endif + , "Symbol:v:not:GHC.Classes:ghc-prim" + , "not defined at " + , " Details: Just Bool -> Bool {usage}" , "Types:" - , "Int -> Bool" - , "forall a. Integral a => a -> Bool" + , "Bool -> Bool" , "" ] @@ -388,4 +353,5 @@ , reindex = False , keepMissing = False , srcBaseDir = Nothing + , skipIndexingOptions = defaultSkipOptions } diff --git a/test/data/Module1.hs b/test/data/Module1.hs --- a/test/data/Module1.hs +++ b/test/data/Module1.hs @@ -5,9 +5,9 @@ import Sub.Module2 (showInt) -function1 :: Int -> String -function1 i = - if even i then "It's even" else "It's odd" +function1 :: Bool -> String +function1 b = + if not b then "It's false" else "It's true" function2 :: Int -> IO () function2 i = putStrLn $ showInt i