hiedb (empty) → 0.1.0.0
raw patch · 15 files changed
+1957/−0 lines, 15 filesdep +algebraic-graphsdep +arraydep +basesetup-changed
Dependencies added: algebraic-graphs, array, base, bytestring, containers, directory, filepath, ghc, ghc-paths, hie-compat, hiedb, hspec, lucid, mtl, optparse-applicative, process, sqlite-simple, terminal-size, text, time
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- exe/Main.hs +8/−0
- hiedb.cabal +79/−0
- src/HieDb.hs +16/−0
- src/HieDb/Create.hs +246/−0
- src/HieDb/Dump.hs +34/−0
- src/HieDb/Html.hs +122/−0
- src/HieDb/Query.hs +253/−0
- src/HieDb/Run.hs +383/−0
- src/HieDb/Types.hs +277/−0
- src/HieDb/Utils.hs +229/−0
- test/Main.hs +253/−0
- test/Test/Orphans.hs +20/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for hiedb++## 0.1.0.0 -- 2020-11-08++* First version.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2019, Zubin Duggal++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Zubin Duggal nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ exe/Main.hs view
@@ -0,0 +1,8 @@+module Main where++import GHC.Paths (libdir)+import HieDb.Run (hiedbMain)+import HieDb.Types (LibDir (..))++main :: IO ()+main = hiedbMain (LibDir libdir)
+ hiedb.cabal view
@@ -0,0 +1,79 @@+cabal-version: 2.4+name: hiedb+version: 0.1.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+license: BSD-3-Clause+license-file: LICENSE+author: Zubin Duggal+maintainer: zubin.duggal@gmail.com+copyright: Zubin Duggal+category: Development+extra-source-files: CHANGELOG.md+++source-repository head+ type: git+ location: https://github.com/wz1000/HieDb++common common-options+ default-language: Haskell2010+ build-depends: base >= 4.12 && < 4.15+ ghc-options: -Wall+ -Wincomplete-uni-patterns+ -Wincomplete-record-updates+ -Wcompat+ -Widentities+ -Wredundant-constraints+ -Wpartial-fields+ -Wno-unrecognised-pragmas+executable hiedb+ import: common-options+ hs-source-dirs: exe+ main-is: Main.hs+ build-depends: base+ , hiedb+ , ghc-paths++library+ import: common-options+ hs-source-dirs: src+ exposed-modules: HieDb,+ HieDb.Utils,+ HieDb.Create,+ HieDb.Query,+ HieDb.Types,+ HieDb.Dump,+ HieDb.Html,+ HieDb.Run+ build-depends: ghc >= 8.6+ , array+ , containers+ , filepath+ , directory+ , mtl+ , sqlite-simple+ , hie-compat+ , time+ , text+ , bytestring+ , algebraic-graphs+ , lucid+ , optparse-applicative+ , terminal-size++test-suite hiedb-tests+ import: common-options+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ other-modules: Test.Orphans+ build-tool-depends: hiedb:hiedb+ build-depends: directory+ , filepath+ , ghc >= 8.6+ , ghc-paths+ , hiedb+ , hspec+ , process
+ src/HieDb.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE BlockArguments #-}+module HieDb+ ( module HieDb.Types+ , module HieDb.Utils+ , module HieDb.Create+ , module HieDb.Query+ , (:.)(..)+ ) where++import HieDb.Types+import HieDb.Utils+import HieDb.Create+import HieDb.Query+import Database.SQLite.Simple+
+ src/HieDb/Create.hs view
@@ -0,0 +1,246 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-}+module HieDb.Create where++import Prelude hiding (mod)++import GHC+import Compat.HieTypes+import Compat.HieUtils+import IfaceType+import Name++import Control.Monad.IO.Class+import Control.Monad+import Control.Exception++import System.Directory++import Database.SQLite.Simple+import Data.Time.Clock+import Data.List ( isSuffixOf )+import Data.String+import Data.Int++import 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 = 4++dB_VERSION :: Integer+dB_VERSION = read (show sCHEMA_VERSION ++ "999" ++ show hieVersion)++{-| @checkVersion f db@ checks the schema version associated with given @db@.+If that version is supported by hiedb, it runs the function @f@ with the @db@.+Otherwise it throws 'IncompatibleSchemaVersion' exception.+-}+checkVersion :: (HieDb -> IO a) -> HieDb -> IO a+checkVersion k db@(getConn -> conn) = do+ [Only ver] <- query_ conn "PRAGMA user_version"+ if ver == 0 then do+ execute_ conn $ fromString $ "PRAGMA user_version = " ++ show dB_VERSION+ k db+ else if ver == dB_VERSION then do+ k db+ else+ throwIO $ IncompatibleSchemaVersion dB_VERSION ver++{-| Given path to @.hiedb@ file, constructs 'HieDb' and passes it to given function. -}+withHieDb :: FilePath -> (HieDb -> IO a) -> IO a+withHieDb fp f = withConnection fp (checkVersion f . HieDb)++{-| Given GHC LibDir and path to @.hiedb@ file, +constructs DynFlags (required for printing info from @.hie@ files)+and 'HieDb' and passes them to given function.+-}+withHieDbAndFlags :: LibDir -> FilePath -> (DynFlags -> HieDb -> IO a) -> IO a+withHieDbAndFlags libdir fp f = do+ dynFlags <- dynFlagsForPrinting libdir+ withConnection fp (checkVersion (f dynFlags) . HieDb)++{-| Initialize database schema for given 'HieDb'.+-}+initConn :: HieDb -> IO ()+initConn (getConn -> conn) = do+ execute_ conn "PRAGMA journal_mode = WAL;"+ execute_ conn "PRAGMA foreign_keys = ON;"+ execute_ conn "PRAGMA defer_foreign_keys = ON;"++ execute_ conn "CREATE TABLE IF NOT EXISTS mods \+ \( hieFile TEXT NOT NULL PRIMARY KEY ON CONFLICT REPLACE \+ \, mod TEXT NOT NULL \+ \, unit TEXT NOT NULL \+ \, is_boot BOOL NOT NULL \+ \, hs_src TEXT UNIQUE ON CONFLICT REPLACE \+ \, is_real BOOL NOT NULL \+ \, time TEXT NOT NULL \+ \, CONSTRAINT modid UNIQUE (mod, unit, is_boot) ON CONFLICT REPLACE \+ \)"++ execute_ conn "CREATE TABLE IF NOT EXISTS refs \+ \( hieFile TEXT NOT NULL \+ \, occ TEXT NOT NULL \+ \, mod TEXT NOT NULL \+ \, unit 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 TABLE IF NOT EXISTS decls \+ \( hieFile TEXT NOT NULL \+ \, occ TEXT NOT NULL \+ \, sl INTEGER NOT NULL \+ \, sc INTEGER NOT NULL \+ \, el INTEGER NOT NULL \+ \, ec INTEGER NOT NULL \+ \, is_root BOOL NOT NULL \+ \, FOREIGN KEY(hieFile) REFERENCES mods(hieFile) ON UPDATE CASCADE ON DELETE CASCADE DEFERRABLE INITIALLY DEFERRED \+ \)"++ execute_ conn "CREATE TABLE IF NOT EXISTS defs \+ \( hieFile TEXT NOT NULL \+ \, occ 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 \+ \, PRIMARY KEY(hieFile,occ) \+ \)"++ execute_ conn "CREATE TABLE IF NOT EXISTS typenames \+ \( id INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT \+ \, name TEXT NOT NULL \+ \, mod TEXT NOT NULL \+ \, unit TEXT NOT NULL \+ \, CONSTRAINT uniqname UNIQUE (name, mod, unit) ON CONFLICT IGNORE \+ \)"++ execute_ conn "CREATE TABLE IF NOT EXISTS typerefs \+ \( id INTEGER NOT NULL \+ \, hieFile TEXT NOT NULL \+ \, depth INTEGER NOT NULL \+ \, sl INTEGER NOT NULL \+ \, sc INTEGER NOT NULL \+ \, el INTEGER NOT NULL \+ \, ec INTEGER NOT NULL \+ \, FOREIGN KEY(id) REFERENCES typenames(id) DEFERRABLE INITIALLY DEFERRED \+ \, FOREIGN KEY(hieFile) REFERENCES mods(hieFile) ON UPDATE CASCADE ON DELETE CASCADE DEFERRABLE INITIALLY DEFERRED \+ \)"++{-| Add names of types from @.hie@ file to 'HieDb'.+Returns an Array mapping 'TypeIndex' to database ID assigned to the +corresponding record in DB.+-}+addArr :: HieDb -> A.Array TypeIndex HieTypeFlat -> IO (A.Array TypeIndex (Maybe Int64))+addArr (getConn -> conn) arr = do+ forM arr $ \case+ HTyVarTy n -> addName n+ HTyConApp tc _ -> addName (ifaceTyConName tc)+ _ -> pure Nothing+ where+ addName :: Name -> IO (Maybe Int64)+ addName n = case nameModule_maybe n of+ Nothing -> pure Nothing+ Just m -> do+ let occ = nameOccName n+ mod = moduleName m+ uid = moduleUnitId 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)++{-| Add references to types from given @.hie@ file to DB. -}+addTypeRefs+ :: HieDb+ -> FilePath -- ^ Path to @.hie@ file+ -> HieFile -- ^ Data loaded from the @.hie@ file+ -> A.Array TypeIndex (Maybe Int64) -- ^ Maps TypeIndex to database ID assigned to record in @typenames@ table+ -> IO ()+addTypeRefs db path hf ixs = mapM_ addTypesFromAst asts+ where+ arr = hie_types hf+ asts = getAsts $ hie_asts hf+ addTypesFromAst :: HieAST TypeIndex -> IO ()+ addTypesFromAst ast = do+ mapM_ (addTypeRef db path arr ixs (nodeSpan ast)) $ mapMaybe identType $ M.elems $ nodeIdentifiers $ nodeInfo ast+ when (null $ nodeChildren ast) $+ mapM_ (addTypeRef db path arr ixs (nodeSpan ast)) $ nodeType $ nodeInfo ast+ mapM_ addTypesFromAst $ nodeChildren ast++{-| 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.+-}+addRefsFrom :: (MonadIO m, NameCacheMonad m) => HieDb -> FilePath -> m ()+addRefsFrom c@(getConn -> conn) path = do+ time <- liftIO $ getModificationTime path+ mods <- liftIO $ query conn "SELECT * FROM mods WHERE hieFile = ? AND time >= ?" (path, time)+ case mods of+ (HieModuleRow{}:_) -> return ()+ [] -> withHieFile path $ \hf -> addRefsFromLoaded c path Nothing False time hf++addRefsFromLoaded+ :: MonadIO m+ => HieDb -- ^ HieDb into which we're adding the file+ -> FilePath -- ^ Path to @.hie@ file+ -> Maybe FilePath -- ^ Path to .hs file from which @.hie@ file was created+ -> Bool -- ^ Is this a real source file? I.e. does it come from user's project (as opposed to from project's dependency)?+ -> UTCTime -- ^ The last modification time of the @.hie@ file+ -> HieFile -- ^ Data loaded from the @.hie@ file+ -> m ()+addRefsFromLoaded db@(getConn -> conn) path srcFile isReal time 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)++ let isBoot = "boot" `isSuffixOf` path+ mod = moduleName smod+ uid = moduleUnitId smod+ smod = hie_module hf+ refmap = generateReferencesMap $ getAsts $ hie_asts hf+ modrow = HieModuleRow path (ModuleInfo mod uid isBoot srcFile isReal time)++ 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++ ixs <- addArr db (hie_types hf)++ let defs = genDefRow path smod refmap+ executeMany conn "INSERT INTO defs VALUES (?,?,?,?,?,?)" defs++ when isReal $+ addTypeRefs db path hf ixs++{-| 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.+-}+addSrcFile+ :: HieDb + -> FilePath -- ^ Path to @.hie@ file+ -> FilePath -- ^ Path to .hs file to be added to DB+ -> Bool -- ^ Is this a real source file? I.e. does it come from user's project (as opposed to from project's dependency)?+ -> IO ()+addSrcFile (getConn -> conn) hie srcFile isReal =+ execute conn "UPDATE mods SET hs_src = ? , is_real = ? WHERE hieFile = ?" (srcFile, isReal, hie)++{-| 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)+ 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)
+ src/HieDb/Dump.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE NamedFieldPuns #-}++module HieDb.Dump where++import qualified Compat.HieDebug as HieDebug+import qualified Compat.HieTypes as HieTypes+import qualified Data.Map.Strict as Map+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Outputable++import Compat.HieTypes (HieFile (..))+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Text (Text)+import DynFlags (DynFlags)+import HieDb.Types (NameCacheMonad)+import HieDb.Utils (withHieFile)++{-| Pretty print Hie AST stored in given .hie file -}+dump ::+ (NameCacheMonad m, MonadIO m)+ => DynFlags+ -> FilePath -- ^ Path to .hie file+ -> m ()+dump dynFlags hieFilePath = do+ withHieFile hieFilePath $ \HieFile{ hie_asts } -> do+ let (_, astRoot) = Map.findMin $ HieTypes.getAsts hie_asts+ liftIO $ putStrLn $ Outputable.showSDoc dynFlags $ HieDebug.ppHie astRoot++{-| Get lines of original source code from given .hie file -}+sourceCode :: (NameCacheMonad m, MonadIO m) => FilePath -> m [Text]+sourceCode hieFilePath =+ withHieFile hieFilePath $ \HieFile {hie_hs_src} ->+ return $ T.lines $ T.decodeUtf8 hie_hs_src
+ src/HieDb/Html.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE OverloadedStrings #-}++module HieDb.Html+ ( Color (..)+ , Span (..)+ , generate+ ) where++import Control.Monad (forM_)+import Data.Function (on)+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IM+import Data.List (foldl', sortBy)+import Data.Text (Text)+import qualified Data.Text as T+import Lucid+import Module++generate :: FilePath -> ModuleName -> [Text] -> [Span] -> IO ()+generate fp mn ts sps = renderToFile fp $ doctypehtml_ $ do+ head_ $ title_ $ toHtml $ moduleNameString mn+ body_ $+ forM_ (layout ts sps) generateLine'+ where+ generateLine' :: (Int, Text, [LineSpan]) -> Html ()+ generateLine' (i, t, lsps) = pre_ [style_ "margin:0em;font-size:large"] $ do+ span_ [style_ "background-color:lightcyan;padding-right:1em"] $ padLineNumber i+ go 1 t lsps++ go :: Int -> Text -> [LineSpan] -> Html ()+ go _ t [] = toHtml t+ go col t lsps@(lsp : lsps')+ | col < lspStartColumn lsp = do+ let (t1, t2) = T.splitAt (lspStartColumn lsp - col) t+ toHtml t1+ go (lspStartColumn lsp) t2 lsps+ | otherwise = do+ let l = lspEndColumn lsp - lspStartColumn lsp + 1+ (t1, t2) = T.splitAt l t+ span_ [lineSpanAttribute lsp] $ toHtml t1+ go (lspEndColumn lsp + 1) t2 lsps'++padLineNumber :: Int -> Html ()+padLineNumber n = let s = show n in go s $ length s+ where+ go s l+ | l >= 6 = toHtml s+ | otherwise = go (' ' : s) (l + 1)++data Color = Reachable | Unreachable deriving (Show, Read, Eq, Ord)++data Span = Span+ { spStartLine :: !Int+ , spStartColumn :: !Int+ , spEndLine :: !Int+ , spEndColumn :: !Int+ , spColor :: !Color+ } deriving (Show, Read, Eq, Ord)++data LineSpan = LineSpan+ { lspLine :: !Int+ , lspStartColumn :: !Int+ , lspEndColumn :: !Int+ , lspColor :: !Color+ } deriving (Show, Read, Eq, Ord)++lineSpanAttribute :: LineSpan -> Attribute+lineSpanAttribute lsp =+ let color = case lspColor lsp of+ Reachable -> "lightgreen"+ Unreachable -> "yellow"+ in style_ $ "background-color:" <> color++lineSpans :: (Int -> Int) -> Span -> [LineSpan]+lineSpans cols sp+ | spStartLine sp == spEndLine sp = return LineSpan+ { lspLine = spStartLine sp+ , lspStartColumn = spStartColumn sp+ , lspEndColumn = spEndColumn sp+ , lspColor = spColor sp+ }+ | otherwise =+ let lsp1 = LineSpan+ { lspLine = spStartLine sp+ , lspStartColumn = spStartColumn sp+ , lspEndColumn = cols $ spStartLine sp+ , lspColor = spColor sp+ }+ lsp i = LineSpan+ { lspLine = i+ , lspStartColumn = 1+ , lspEndColumn = cols i+ , lspColor = spColor sp+ }+ lsp2 = LineSpan+ { lspLine = spEndLine sp+ , lspStartColumn = 1+ , lspEndColumn = spEndColumn sp+ , lspColor = spColor sp+ }+ in lsp1 : [lsp i | i <- [spStartLine sp + 1 .. spEndLine sp - 1]] ++ [lsp2]++layout :: [Text] -> [Span] -> [(Int, Text, [LineSpan])]+layout ts ss =+ let m1 = IM.fromList [(i, (t, T.length t, [])) | (i, t) <- zip [1..] ts]+ m2 = foldl' f m1 ss :: IntMap (Text, Int, [LineSpan])+ in [(i, t, lsps) | (i, (t, lsps)) <- IM.toList $ j <$> m2]+ where+ f :: IntMap (Text, Int, [LineSpan]) -> Span -> IntMap (Text, Int, [LineSpan])+ f m = foldl' g m . lineSpans lookup'+ where lookup' i = case IM.lookup i m of+ Nothing -> 0+ Just (_, l, _) -> l++ g :: IntMap (Text, Int, [LineSpan]) -> LineSpan -> IntMap (Text, Int, [LineSpan])+ g m lsp = IM.adjust (h lsp) (lspLine lsp) m++ h :: LineSpan -> (Text, Int, [LineSpan]) -> (Text, Int, [LineSpan])+ h lsp (t, l, lsps) = (t, l, lsp : lsps)++ j :: (Text, Int, [LineSpan]) -> (Text, [LineSpan])+ j (t, _, lsps) = (t, sortBy (compare `on` lspStartColumn) lsps)
+ src/HieDb/Query.hs view
@@ -0,0 +1,253 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}+module HieDb.Query where++import Algebra.Graph.AdjacencyMap (AdjacencyMap, edges, vertexSet, vertices, overlay)+import Algebra.Graph.AdjacencyMap.Algorithm (dfs)+import Algebra.Graph.Export.Dot hiding ((:=))+import qualified Algebra.Graph.Export.Dot as G++import GHC+import Compat.HieTypes+import Module+import Name++import System.Directory+import System.FilePath++import Control.Monad (foldM, forM_)+import Control.Monad.IO.Class++import Data.List (foldl', intercalate)+import Data.List.NonEmpty (NonEmpty(..))+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Set (Set)+import qualified Data.Set as Set+import qualified Data.Text as T+import Data.IORef++import Database.SQLite.Simple++import HieDb.Dump (sourceCode)+import HieDb.Types+import HieDb.Utils+import HieDb.Create+import qualified HieDb.Html as Html++{-| List all modules indexed in HieDb. -}+getAllIndexedMods :: HieDb -> IO [HieModuleRow]+getAllIndexedMods (getConn -> conn) = query_ conn "SELECT * FROM mods"++{-| Lookup UnitId associated with given ModuleName.+HieDbErr is returned if no module with given name has been indexed+or if ModuleName is ambiguous (i.e. there are multiple packages containing module with given name)+-}+resolveUnitId :: HieDb -> ModuleName -> IO (Either HieDbErr UnitId)+resolveUnitId (getConn -> conn) mn = do+ luid <- query conn "SELECT mod, unit, is_boot, hs_src, is_real, time FROM mods WHERE mod = ? and is_boot = 0" (Only mn)+ return $ case luid of+ [] -> Left $ NotIndexed mn Nothing+ [x] -> Right $ modInfoUnit x+ (x:xs) -> Left $ AmbiguousUnitId $ x :| xs++search :: HieDb -> Bool -> OccName -> Maybe ModuleName -> Maybe UnitId -> [FilePath] -> IO [Res RefRow]+search (getConn -> conn) isReal occ mn uid exclude =+ queryNamed conn thisQuery ([":occ" := occ, ":mod" := mn, ":unit" := uid, ":real" := isReal] ++ excludedFields)+ where+ excludedFields = zipWith (\n f -> (":exclude" <> T.pack (show n)) := f) [1 :: Int ..] exclude+ thisQuery =+ "SELECT refs.*,mods.mod,mods.unit,mods.is_boot,mods.hs_src,mods.is_real,mods.time \+ \FROM refs JOIN mods USING (hieFile) \+ \WHERE refs.occ = :occ AND (:mod IS NULL OR refs.mod = :mod) AND (:unit is NULL OR refs.unit = :unit) AND ( (NOT :real) OR (mods.is_real AND mods.hs_src IS NOT NULL))"+ <> " AND mods.hs_src NOT IN (" <> Query (T.intercalate "," (map (\(l := _) -> l) excludedFields)) <> ")"++{-| Lookup 'HieModule' row from 'HieDb' given its 'ModuleName' and 'UnitId' -}+lookupHieFile :: HieDb -> ModuleName -> UnitId -> IO (Maybe HieModuleRow)+lookupHieFile (getConn -> conn) mn uid = do+ files <- query conn "SELECT * FROM mods WHERE mod = ? AND unit = ? AND is_boot = 0" (mn, uid)+ case files of+ [] -> return Nothing+ [x] -> return $ Just x+ xs ->+ error $ "DB invariant violated, (mod,unit) in mods not unique: "+ ++ show (moduleNameString mn, uid) ++ ". Entries: "+ ++ intercalate ", " (map hieModuleHieFile xs)++{-| Lookup 'HieModule' row from 'HieDb' given the path to the Haskell source file -}+lookupHieFileFromSource :: HieDb -> FilePath -> IO (Maybe HieModuleRow)+lookupHieFileFromSource (getConn -> conn) fp = do+ files <- query conn "SELECT * FROM mods WHERE hs_src = ?" (Only fp)+ case files of+ [] -> return Nothing+ [x] -> return $ Just x+ xs ->+ error $ "DB invariant violated, hs_src in mods not unique: "+ ++ show fp ++ ". Entries: "+ ++ intercalate ", " (map (show . toRow) xs)++findTypeRefs :: HieDb -> OccName -> ModuleName -> UnitId -> IO [Res TypeRef]+findTypeRefs (getConn -> conn) occ mn uid+ = query conn "SELECT typerefs.*, mods.mod,mods.unit,mods.is_boot,mods.hs_src,mods.is_real,mods.time \+ \FROM typerefs JOIN mods ON typerefs.hieFile = mods.hieFile \+ \JOIN typenames ON typerefs.id = typenames.id \+ \WHERE typenames.name = ? AND typenames.mod = ? AND typenames.unit = ? AND mods.is_real \+ \ORDER BY typerefs.depth ASC"+ (occ,mn,uid)++findDef :: HieDb -> OccName -> Maybe ModuleName -> Maybe UnitId -> IO [Res DefRow]+findDef conn occ mn uid+ = queryNamed (getConn conn) "SELECT defs.*, mods.mod,mods.unit,mods.is_boot,mods.hs_src,mods.is_real,mods.time \+ \FROM defs JOIN mods USING (hieFile) \+ \WHERE occ = :occ AND (:mod IS NULL OR mod = :mod) AND (:unit IS NULL OR unit = :unit)"+ [":occ" := occ,":mod" := mn, ":unit" := uid]++findOneDef :: HieDb -> OccName -> Maybe ModuleName -> Maybe UnitId -> IO (Either HieDbErr (Res DefRow))+findOneDef conn occ mn muid = wrap <$> findDef conn occ mn muid+ where+ wrap [x] = Right x+ wrap [] = Left $ NameNotFound occ mn muid+ wrap (x:xs) = Left $ AmbiguousUnitId (defUnit x :| map defUnit xs)+ defUnit (_:.i) = i++searchDef :: HieDb -> String -> IO [Res DefRow]+searchDef conn cs+ = query (getConn conn) "SELECT defs.*,mods.mod,mods.unit,mods.is_boot,mods.hs_src,mods.is_real,mods.time \+ \FROM defs JOIN mods USING (hieFile) \+ \WHERE occ LIKE ? \+ \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 UnitId) it is first resolved+from HieDb, which can lead to error if given file is not indexed/Module name is ambiguous.+-}+withTarget+ :: HieDb+ -> HieTarget+ -> (HieFile -> a)+ -> IO (Either HieDbErr a)+withTarget conn target f = case target of+ Left fp -> processHieFile fp+ Right (mn,muid) -> do+ euid <- maybe (resolveUnitId conn mn) (return . Right) muid+ case euid of+ Left err -> return $ Left err+ Right uid -> do+ mModRow <- lookupHieFile conn mn uid+ case mModRow of+ Nothing -> return $ Left (NotIndexed mn $ Just uid)+ Just modRow -> processHieFile (hieModuleHieFile modRow)+ where+ processHieFile fp = do+ fp' <- canonicalizePath fp+ nc <- newIORef =<< makeNc+ runDbM nc $ do+ addRefsFrom conn fp'+ Right <$> withHieFile fp' (return . f)+ ++type Vertex = (String, String, String, Int, Int, Int, Int)++declRefs :: HieDb -> IO ()+declRefs db = do+ graph <- getGraph db+ writeFile+ "refs.dot"+ ( export+ ( ( defaultStyle ( \( _, hie, occ, _, _, _, _ ) -> hie <> ":" <> occ ) )+ { vertexAttributes = \( mod', _, occ, _, _, _, _ ) ->+ [ "label" G.:= ( mod' <> "." <> drop 1 occ )+ , "fillcolor" G.:= case occ of ('v':_) -> "red"; ('t':_) -> "blue";_ -> "black"+ ]+ }+ )+ graph+ )++getGraph :: HieDb -> IO (AdjacencyMap Vertex)+getGraph (getConn -> conn) = do+ es <-+ query_ conn "SELECT mods.mod, decls.hieFile, decls.occ, decls.sl, decls.sc, decls.el, decls.ec, \+ \rmods.mod, ref_decl.hieFile, ref_decl.occ, ref_decl.sl, ref_decl.sc, ref_decl.el, ref_decl.ec \+ \FROM decls JOIN refs ON refs.hieFile = decls.hieFile \+ \JOIN mods ON mods.hieFile = decls.hieFile \+ \JOIN mods AS rmods ON rmods.mod = refs.mod AND rmods.unit = refs.unit AND rmods.is_boot = 0 \+ \JOIN decls AS ref_decl ON ref_decl.hieFile = rmods.hieFile AND ref_decl.occ = refs.occ \+ \WHERE ((refs.sl > decls.sl) OR (refs.sl = decls.sl AND refs.sc > decls.sc)) \+ \AND ((refs.el < decls.el) OR (refs.el = decls.el AND refs.ec <= decls.ec))"+ vs <-+ query_ conn "SELECT mods.mod, decls.hieFile, decls.occ, decls.sl, decls.sc, decls.el, decls.ec \+ \FROM decls JOIN mods USING (hieFile)"+ return $ overlay ( vertices vs ) ( edges ( map (\( x :. y ) -> ( x, y )) es ) )++getVertices :: HieDb -> [Symbol] -> IO [Vertex]+getVertices (getConn -> conn) ss = Set.toList <$> foldM f Set.empty ss+ where+ f :: Set Vertex -> Symbol -> IO (Set Vertex)+ f vs s = foldl' (flip Set.insert) vs <$> one s++ one :: Symbol -> IO [Vertex]+ one s = do+ let n = toNsChar (occNameSpace $ symName s) : occNameString (symName s)+ m = moduleNameString $ moduleName $ symModule s+ u = unitIdString (moduleUnitId $ symModule s)+ query conn "SELECT mods.mod, decls.hieFile, decls.occ, decls.sl, decls.sc, decls.el, decls.ec \+ \FROM decls JOIN mods USING (hieFile) \+ \WHERE ( decls.occ = ? AND mods.mod = ? AND mods.unit = ? ) " (n, m, u)++getReachable :: HieDb -> [Symbol] -> IO [Vertex]+getReachable db symbols = fst <$> getReachableUnreachable db symbols++getUnreachable :: HieDb -> [Symbol] -> IO [Vertex]+getUnreachable db symbols = snd <$> getReachableUnreachable db symbols++html :: (NameCacheMonad m, MonadIO m) => HieDb -> [Symbol] -> m ()+html db symbols = do+ m <- liftIO $ getAnnotations db symbols+ forM_ (Map.toList m) $ \(fp, (mod', sps)) -> do+ code <- sourceCode fp+ let fp' = replaceExtension fp "html"+ liftIO $ putStrLn $ moduleNameString mod' ++ ": " ++ fp'+ liftIO $ Html.generate fp' mod' code $ Set.toList sps++getAnnotations :: HieDb -> [Symbol] -> IO (Map FilePath (ModuleName, Set Html.Span))+getAnnotations db symbols = do+ (rs, us) <- getReachableUnreachable db symbols+ let m1 = foldl' (f Html.Reachable) Map.empty rs+ m2 = foldl' (f Html.Unreachable) m1 us+ return m2+ where+ f :: Html.Color + -> Map FilePath (ModuleName, Set Html.Span) + -> Vertex + -> Map FilePath (ModuleName, Set Html.Span)+ f c m v =+ let (fp, mod', sp) = g c v+ in Map.insertWith h fp (mod', Set.singleton sp) m++ g :: Html.Color -> Vertex -> (FilePath, ModuleName, Html.Span)+ g c (mod', fp, _, sl, sc, el, ec) = (fp, mkModuleName mod', Html.Span+ { Html.spStartLine = sl+ , Html.spStartColumn = sc+ , Html.spEndLine = el+ , Html.spEndColumn = ec+ , Html.spColor = c+ })++ h :: (ModuleName, Set Html.Span)+ -> (ModuleName, Set Html.Span)+ -> (ModuleName, Set Html.Span)+ h (m, sps) (_, sps') = (m, sps <> sps')++getReachableUnreachable :: HieDb -> [Symbol] -> IO ([Vertex], [Vertex])+getReachableUnreachable db symbols = do+ vs <- getVertices db symbols+ graph <- getGraph db+ let (xs, ys) = splitByReachability graph vs+ return (Set.toList xs, Set.toList ys)++splitByReachability :: Ord a => AdjacencyMap a -> [a] -> (Set a, Set a)+splitByReachability m vs = let s = Set.fromList (dfs vs m) in (s, vertexSet m Set.\\ s)
+ src/HieDb/Run.hs view
@@ -0,0 +1,383 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BlockArguments #-}+module HieDb.Run where++import Prelude hiding (mod)++import GHC+import Compat.HieTypes+import Compat.HieUtils+import Name+import Module+import Outputable ((<+>),hang,showSDoc,ppr,text)++import qualified FastString as FS++import qualified Data.Map as M++import qualified Data.Text.IO as T+++import System.Environment+import System.Directory+import System.IO+import System.Exit++import System.Console.Terminal.Size++import Control.Monad+import Control.Monad.IO.Class++import Data.Maybe+import Data.Either+import Data.Foldable+import Data.IORef++import qualified Data.ByteString.Char8 as BS++import Options.Applicative++import HieDb+import HieDb.Dump++hiedbMain :: LibDir -> IO ()+hiedbMain libdir = do+ defaultLoc <- getXdgDirectory XdgData $ "default_"++ show dB_VERSION ++".hiedb"+ defdb <- fromMaybe defaultLoc <$> lookupEnv "HIEDB"+ hSetBuffering stdout NoBuffering+ (opts, cmd) <- execParser $ progParseInfo defdb+ runCommand libdir opts cmd+++{- USAGE+Some default db location overridden by environment var HIEDB+hiedb init <foo.hiedb>+hiedb index [<dir>...] [hiedb]+hiedb name-refs <name> <module> [unitid] [hiedb]+hiedb type-refs <name> <module> [unitid] [hiedb]+hiedb query-pos <file.hie> <row> <col> [hiedb]+hiedb query-pos --hiedir=<dir> <file.hs> <row> <col> [hiedb]+hiedb cat <module> [unitid]+-}++data Options+ = Options+ { database :: FilePath+ , trace :: Bool+ , quiet :: Bool+ , virtualFile :: Bool+ }++data Command+ = Init+ | Index [FilePath]+ | NameRefs String (Maybe ModuleName) (Maybe UnitId)+ | TypeRefs String (Maybe ModuleName) (Maybe UnitId)+ | NameDef String (Maybe ModuleName) (Maybe UnitId)+ | TypeDef String (Maybe ModuleName) (Maybe UnitId)+ | Cat HieTarget+ | Ls+ | Rm [HieTarget]+ | ModuleUIDs ModuleName+ | LookupHieFile ModuleName (Maybe UnitId)+ | RefsAtPoint HieTarget (Int,Int) (Maybe (Int,Int))+ | TypesAtPoint HieTarget (Int,Int) (Maybe (Int,Int))+ | DefsAtPoint HieTarget (Int,Int) (Maybe (Int,Int))+ | InfoAtPoint HieTarget (Int,Int) (Maybe (Int,Int))+ | RefGraph+ | Dump FilePath+ | Reachable [Symbol]+ | Unreachable [Symbol]+ | Html [Symbol]++progParseInfo :: FilePath -> ParserInfo (Options, Command)+progParseInfo db = info (progParser db <**> 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++optParser :: FilePath -> Parser Options+optParser defdb+ = 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)++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 "name-refs" (info (NameRefs <$> strArgument (metavar "NAME")+ <*> optional (mkModuleName <$> strArgument (metavar "MODULE"))+ <*> maybeUnitId)+ $ progDesc "Lookup references of value MODULE.NAME")+ <> command "type-refs" (info (TypeRefs <$> strArgument (metavar "NAME")+ <*> optional moduleNameParser+ <*> maybeUnitId)+ $ progDesc "Lookup references of type MODULE.NAME")+ <> command "name-def" (info (NameDef <$> strArgument (metavar "NAME")+ <*> optional moduleNameParser+ <*> maybeUnitId)+ $ progDesc "Lookup definition of value MODULE.NAME")+ <> command "type-def" (info (TypeDef <$> strArgument (metavar "NAME")+ <*> optional moduleNameParser+ <*> maybeUnitId)+ $ progDesc "Lookup definition of type MODULE.NAME")+ <> command "cat" (info (Cat <$> hieTarget)+ $ progDesc "Dump contents of MODULE as stored in the hiefile")+ <> command "ls" (info (pure Ls)+ $ progDesc "List all indexed files/modules")+ <> command "rm" (info (Rm <$> many hieTarget)+ $ progDesc "Remove targets from index")+ <> command "module-uids" (info (ModuleUIDs <$> moduleNameParser)+ $ progDesc "List all the UnitIds MODULE is indexed under in the db")+ <> command "lookup-hie" (info (LookupHieFile <$> moduleNameParser <*> maybeUnitId)+ $ progDesc "Lookup the location of the .hie file corresponding to MODULE")+ <> command "point-refs"+ (info (RefsAtPoint <$> hieTarget+ <*> posParser 'S'+ <*> optional (posParser 'E'))+ $ progDesc "Find references for symbol at point/span")+ <> command "point-types"+ (info (TypesAtPoint <$> hieTarget+ <*> posParser 'S'+ <*> optional (posParser 'E'))+ $ progDesc "List types of ast at point/span")+ <> command "point-defs"+ (info (DefsAtPoint <$> hieTarget+ <*> posParser 'S'+ <*> optional (posParser 'E'))+ $ progDesc "Find definition for symbol at point/span")+ <> command "point-info"+ (info (InfoAtPoint <$> hieTarget+ <*> posParser 'S'+ <*> optional (posParser 'E'))+ $ progDesc "Print name, module name, unit id for symbol at point/span")+ <> command "ref-graph" (info (pure RefGraph) $ progDesc "Generate a reachability graph")+ <> command "dump" (info (Dump <$> strArgument (metavar "HIE")) $ progDesc "Dump a HIE AST")+ <> command "reachable" (info (Reachable <$> some symbolParser)+ $ progDesc "Find all symbols reachable from the given symbols")+ <> command "unreachable" (info (Unreachable <$> some symbolParser)+ $ 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")++posParser :: Char -> Parser (Int,Int)+posParser c = (,) <$> argument auto (metavar $ c:"LINE") <*> argument auto (metavar $ c:"COL")++maybeUnitId :: Parser (Maybe UnitId)+maybeUnitId =+ optional (stringToUnitId <$> strOption (short 'u' <> long "unit-id" <> metavar "UNITID"))++symbolParser :: Parser Symbol+symbolParser = argument auto $ metavar "SYMBOL"++moduleNameParser :: Parser ModuleName+moduleNameParser = mkModuleName <$> strArgument (metavar "MODULE")++hieTarget :: Parser HieTarget+hieTarget =+ (Left <$> strOption (long "hiefile" <> short 'f' <> metavar "HIEFILE"))+ <|> (Right <$> ((,) <$> moduleNameParser <*> maybeUnitId))++progress :: Int -> Int -> Int -> (FilePath -> DbMonad a) -> FilePath -> DbMonad a+progress l total cur act f = do+ liftIO $ putStr $ replicate l ' '+ liftIO $ putStr "\r"+ let msg = take (l-8) $ unwords ["Processing file", show (cur + 1) ++ "/" ++ show total ++ ":", f] ++ "..."+ liftIO $ putStr msg+ x <- act f+ liftIO $ putStr " done\r"+ return x++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: "<>))+ case cmd of+ Init -> initConn conn+ Index dirs -> do+ initConn conn+ files <- concat <$> mapM getHieFilesIn dirs+ nc <- newIORef =<< makeNc+ wsize <- maybe 80 width <$> size+ let progress' = if quiet opts then (\_ _ _ k -> k) else progress+ runDbM nc $+ zipWithM_ (\f n -> progress' wsize (length files) n (addRefsFrom conn) f) files [0..]+ unless (quiet opts) $+ putStrLn "\nCompleted!"+ TypeRefs typ mn muid -> do+ let occ = mkOccName tcClsName typ+ refs <- search conn False occ mn muid []+ reportRefs refs+ NameRefs nm mn muid -> do+ let ns = if isCons nm then dataName else varName+ let occ = mkOccName ns nm+ refs <- search conn False occ mn muid []+ reportRefs 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+ let mdl = mkModule (modInfoUnit inf) (modInfoName inf)+ reportRefSpans [(mdl, (defSLine row, defSCol row), (defELine row, defECol row))]+ TypeDef nm mn muid -> do+ let occ = mkOccName tcClsName nm+ (row:.inf) <- reportAmbiguousErr =<< 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)+ Ls -> do+ mods <- getAllIndexedMods conn+ forM_ mods $ \mod -> do+ putStr $ hieModuleHieFile mod+ putStr "\t"+ putStr $ moduleNameString $ modInfoName $ hieModInfo mod+ putStr "\t"+ putStrLn $ unitIdString $ modInfoUnit $ hieModInfo mod+ Rm targets -> do+ forM_ targets $ \target -> do+ case target of+ Left f -> do+ dir <- doesDirectoryExist f+ if dir+ then do+ fs <- getHieFilesIn f+ mapM_ (deleteFileFromIndex conn) fs+ else do+ cf <- canonicalizePath f+ deleteFileFromIndex conn cf+ Right (mn,muid) -> do+ uid <- reportAmbiguousErr =<< maybe (resolveUnitId conn mn) (return . Right) muid+ mFile <- lookupHieFile conn mn uid+ case mFile of+ Nothing -> reportAmbiguousErr $ Left (NotIndexed mn $ Just uid)+ Just x -> deleteFileFromIndex conn (hieModuleHieFile x)+ ModuleUIDs mn ->+ print =<< reportAmbiguousErr =<< resolveUnitId conn mn+ LookupHieFile mn muid -> reportAmbiguousErr =<< do+ euid <- maybe (resolveUnitId conn mn) (return . Right) muid+ case euid of+ Left err -> return $ Left err+ Right uid -> do+ mFile <- lookupHieFile conn mn uid+ 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+ let names = concat $ pointCommand hf sp mep $ rights . M.keys . nodeIdentifiers . nodeInfo+ forM_ names $ \name -> do+ putStrLn $ unwords ["Name", occNameString (nameOccName name),"at",show sp,"is used in:"]+ case nameModule_maybe name of+ Just mod -> do+ reportRefs =<< search conn False (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnitId mod) []+ 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+ let types' = concat $ pointCommand hf sp mep $ nodeType . nodeInfo+ types = map (flip recoverFullType $ hie_types hf) types'+ forM_ types $ \typ -> do+ putStrLn $ renderHieType dynFlags typ+ DefsAtPoint target sp mep -> hieFileCommand conn target $ \hf -> do+ let names = concat $ pointCommand hf sp mep $ rights . M.keys . nodeIdentifiers . nodeInfo+ 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))]+ UnhelpfulSpan msg -> do+ case nameModule_maybe name of+ Just mod -> do+ (row:.inf) <- reportAmbiguousErr+ =<< 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))]+ Nothing -> do+ reportAmbiguousErr $ Left $ NameUnhelpfulSpan name (FS.unpackFS msg)+ InfoAtPoint target sp mep -> hieFileCommand conn target $ \hf -> do+ mapM_ (uncurry $ printInfo dynFlags) $ pointCommand hf sp mep $ \ast ->+ (renderHieType dynFlags . flip recoverFullType (hie_types hf) <$> nodeInfo ast, nodeSpan ast)+ RefGraph -> declRefs conn+ Dump path -> do+ nc <- newIORef =<< makeNc+ runDbM nc $ dump dynFlags path+ Reachable s -> getReachable conn s >>= mapM_ print+ Unreachable s -> getUnreachable conn s >>= mapM_ print+ Html s -> do+ nc <- newIORef =<< makeNc+ runDbM nc $ html conn s++printInfo :: DynFlags -> NodeInfo String -> RealSrcSpan -> IO ()+printInfo dynFlags x sp = do+ putStrLn $ "Span: " ++ showSDoc dynFlags (ppr sp)+ putStrLn $ "Constructors: " ++ showSDoc dynFlags (ppr $ nodeAnnotations x)+ putStrLn "Identifiers:"+ let idents = M.toList $ nodeIdentifiers x+ forM_ idents $ \(ident,inf) -> do+ case ident of+ Left mdl -> putStrLn $ "Module: " ++ moduleNameString mdl+ Right nm -> do+ case nameModule_maybe nm of+ Nothing -> pure ()+ Just m -> do+ putStr "Symbol:"+ print $ Symbol (nameOccName nm) m+ putStrLn $ showSDoc dynFlags $+ hang (ppr nm <+> text "defined at" <+> ppr (nameSrcSpan nm)) 4 (ppr inf)+ putStrLn "Types:"+ let types = nodeType x+ forM_ types $ \typ -> do+ putStrLn typ+ putStrLn ""++hieFileCommand :: HieDb -> HieTarget -> (HieFile -> IO a) -> IO a+hieFileCommand conn target f = join $ reportAmbiguousErr =<< withTarget conn target f++reportAmbiguousErr :: Either HieDbErr a -> IO a+reportAmbiguousErr (Right x) = return x+reportAmbiguousErr (Left e) = do+ putStrLn $ showHieDbErr e+ exitFailure++showHieDbErr :: HieDbErr -> String+showHieDbErr e = case e of+ NotIndexed mn muid -> unwords ["Module", moduleNameString mn ++ maybe "" (\uid -> "("++show 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]+ 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+ ]++reportRefs :: [Res RefRow] -> IO ()+reportRefs xs = reportRefSpans+ [ (mdl,(refSLine x, refSCol x),(refELine x, refECol x))+ | (x:.inf) <- xs+ , let mdl = mkModule (modInfoUnit inf) (modInfoName inf)+ ]
+ src/HieDb/Types.hs view
@@ -0,0 +1,277 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -Wno-orphans #-}+module HieDb.Types where++import Prelude hiding (mod)++import Name+import Module+import NameCache++import IfaceEnv (NameCacheUpdater(..))+import Data.IORef++import qualified Data.Text as T++import Control.Monad.IO.Class+import Control.Monad.Reader+import Control.Exception++import Data.List.NonEmpty (NonEmpty(..))++import Data.Time.Clock+import Data.Int++import Database.SQLite.Simple+import Database.SQLite.Simple.ToField+import Database.SQLite.Simple.FromField++import qualified Text.ParserCombinators.ReadP as R++newtype HieDb = HieDb { getConn :: Connection }++data HieDbException+ = IncompatibleSchemaVersion+ { expectedVersion :: Integer, gotVersion :: Integer }+ deriving (Eq,Ord,Show)++instance Exception HieDbException where++setHieTrace :: HieDb -> Maybe (T.Text -> IO ()) -> IO ()+setHieTrace = setTrace . getConn++data ModuleInfo+ = ModuleInfo+ { modInfoName :: ModuleName+ , modInfoUnit :: UnitId -- ^ Identifies the package this module is part of+ , modInfoIsBoot :: Bool -- ^ True, when this ModuleInfo was created by indexing @.hie-boot@ file;+ -- False when it was created from @.hie@ file+ , modInfoSrcFile :: Maybe FilePath -- ^ The path to the haskell source file, from which the @.hie@ file was created+ , modInfoIsReal :: Bool -- ^ Is this a real source file? I.e. does it come from user's project (as opposed to from project's dependency)?+ , modInfoTime :: UTCTime -- ^ The last modification time of the @.hie@ file from which this ModuleInfo was created+ }++instance Show ModuleInfo where+ show = show . toRow++instance ToRow ModuleInfo where+ toRow (ModuleInfo a b c d e f) = toRow (a,b,c,d,e,f)+instance FromRow ModuleInfo where+ fromRow = ModuleInfo <$> field <*> field <*> field+ <*> field <*> field <*> field++type Res a = a :. ModuleInfo++instance ToField ModuleName where+ toField mod = SQLText $ T.pack $ moduleNameString mod+instance FromField ModuleName where+ fromField fld = mkModuleName . T.unpack <$> fromField fld++instance ToField UnitId where+ toField uid = SQLText $ T.pack $ unitIdString uid+instance FromField UnitId where+ fromField fld = stringToUnitId . T.unpack <$> fromField fld++toNsChar :: NameSpace -> Char+toNsChar ns+ | isVarNameSpace ns = 'v'+ | isDataConNameSpace ns = 'c'+ | isTcClsNameSpace ns = 't'+ | isTvNameSpace ns = 'z'+ | otherwise = error "namespace not recognized"++fromNsChar :: Char -> Maybe NameSpace+fromNsChar 'v' = Just varName+fromNsChar 'c' = Just dataName+fromNsChar 't' = Just tcClsName+fromNsChar 'z' = Just tvName+fromNsChar _ = Nothing++instance ToField OccName where+ toField occ = SQLText $ T.pack $ toNsChar (occNameSpace occ) : occNameString occ+instance FromField OccName where+ fromField fld =+ case fieldData fld of+ SQLText t ->+ case T.uncons t of+ Just (nsChar,occ)+ | Just ns <- fromNsChar nsChar ->+ return $ mkOccName ns (T.unpack occ)+ _ -> returnError ConversionFailed fld "OccName encoding invalid"+ _ -> returnError Incompatible fld "Expected a SQL string representing an OccName"++data HieModuleRow+ = HieModuleRow+ { hieModuleHieFile :: FilePath -- ^ Full path to @.hie@ file based on which this row was created+ , hieModInfo :: ModuleInfo+ }++instance ToRow HieModuleRow where+ toRow (HieModuleRow a b) =+ toField a : toRow b++instance FromRow HieModuleRow where+ fromRow =+ HieModuleRow <$> field <*> fromRow++data RefRow+ = RefRow+ { refSrc :: FilePath+ , refNameOcc :: OccName+ , refNameMod :: ModuleName+ , refNameUnit :: UnitId+ , refSLine :: Int+ , refSCol :: Int+ , refELine :: Int+ , refECol :: Int+ }++instance ToRow RefRow where+ toRow (RefRow a b c d e f g h) = toRow ((a,b,c):.(d,e,f):.(g,h))++instance FromRow RefRow where+ fromRow = RefRow <$> field <*> field <*> field+ <*> field <*> field <*> field+ <*> field <*> field++data DeclRow+ = DeclRow+ { declSrc :: FilePath+ , declNameOcc :: OccName+ , declSLine :: Int+ , declSCol :: Int+ , declELine :: Int+ , declECol :: Int+ , declRoot :: Bool+ }++instance ToRow DeclRow where+ toRow (DeclRow a b c d e f g) = toRow ((a,b,c,d):.(e,f,g))++instance FromRow DeclRow where+ fromRow = DeclRow <$> field <*> field <*> field <*> field+ <*> field <*> field <*> field++data TypeName = TypeName+ { typeName :: OccName+ , typeMod :: ModuleName+ , typeUnit :: UnitId+ }++data TypeRef = TypeRef+ { typeRefOccId :: Int64+ , typeRefHieFile :: FilePath+ , typeRefDepth :: Int+ , typeRefSLine :: Int+ , typeRefSCol :: Int+ , typeRefELine :: Int+ , typeRefECol :: Int+ }++instance ToRow TypeRef where+ toRow (TypeRef a b c d e f g) = toRow ((a,b,c,d):.(e,f,g))++instance FromRow TypeRef where+ fromRow = TypeRef <$> field <*> field <*> field <*> field+ <*> field <*> field <*> field++data DefRow+ = DefRow+ { defSrc :: FilePath+ , defNameOcc :: OccName+ , defSLine :: Int+ , defSCol :: Int+ , defELine :: Int+ , defECol :: Int+ }++instance ToRow DefRow where+ toRow (DefRow a b c d e f) = toRow ((a,b,c,d):.(e,f))++instance FromRow DefRow where+ fromRow = DefRow <$> field <*> field <*> field <*> field+ <*> field <*> field+++{-| Monad with access to 'NameCacheUpdater', which is needed to deserialize @.hie@ files -}+class Monad m => NameCacheMonad m where+ getNcUpdater :: m NameCacheUpdater++newtype DbMonadT m a = DbMonadT { runDbMonad :: ReaderT (IORef NameCache) m a } deriving (MonadTrans)+deriving instance Monad m => Functor (DbMonadT m)+deriving instance Monad m => Applicative (DbMonadT m)+deriving instance Monad m => Monad (DbMonadT m)+deriving instance MonadIO m => MonadIO (DbMonadT m)++type DbMonad = DbMonadT IO++runDbM :: IORef NameCache -> DbMonad a -> IO a+runDbM nc x = flip runReaderT nc $ runDbMonad x++instance MonadIO m => NameCacheMonad (DbMonadT m) where+ getNcUpdater = DbMonadT $ ReaderT $ \ref -> pure (NCU $ atomicModifyIORef' ref)+++data HieDbErr+ = NotIndexed ModuleName (Maybe UnitId)+ | AmbiguousUnitId (NonEmpty ModuleInfo)+ | NameNotFound OccName (Maybe ModuleName) (Maybe UnitId)+ | NameUnhelpfulSpan Name String++data Symbol = Symbol+ { symName :: !OccName+ , symModule :: !Module+ } deriving (Eq, Ord)++instance Show Symbol where+ show s = toNsChar (occNameSpace $ symName s)+ : ':'+ : occNameString (symName s)+ <> ":"+ <> moduleNameString (moduleName $ symModule s)+ <> ":"+ <> unitIdString (moduleUnitId $ symModule s)++instance Read Symbol where+ readsPrec = const $ R.readP_to_S readSymbol++readNameSpace :: R.ReadP NameSpace+readNameSpace = do+ c <- R.get+ maybe R.pfail return (fromNsChar c)++readColon :: R.ReadP ()+readColon = () <$ R.char ':'++readSymbol :: R.ReadP Symbol+readSymbol = do+ ns <- readNameSpace+ readColon+ n <- R.many1 R.get+ readColon+ m <- R.many1 R.get+ readColon+ u <- R.many1 R.get+ R.eof+ let mn = mkModuleName m+ uid = stringToUnitId u+ sym = Symbol+ { symName = mkOccName ns n+ , symModule = mkModule uid mn+ }+ return sym++-- | GHC Library Directory. Typically you'll want to use+-- @libdir@ from <https://hackage.haskell.org/package/ghc-paths ghc-paths>+newtype LibDir = LibDir FilePath++-- | A way to specify which HieFile to operate on.+-- Either the path to @.hie@ file is given in the Left+-- Or ModuleName (with optional UnitId) is given in the Right+type HieTarget = Either FilePath (ModuleName, Maybe UnitId)
+ src/HieDb/Utils.hs view
@@ -0,0 +1,229 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE CPP #-}+module HieDb.Utils where++import qualified Data.Tree++import Prelude hiding (mod)++import Compat.HieBin+import Compat.HieTypes+import qualified Compat.HieTypes as HieTypes+import Compat.HieUtils+import Name+import Module+import NameCache+import UniqSupply+import SrcLoc+import DynFlags+import SysTools++import qualified Data.Map as M++import qualified FastString as FS++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++import Data.Char+import Data.Int+import Data.Maybe+import Data.Monoid+import Data.IORef++import HieDb.Types+import Database.SQLite.Simple++addTypeRef :: HieDb -> FilePath -> A.Array TypeIndex HieTypeFlat -> A.Array TypeIndex (Maybe Int64) -> RealSrcSpan -> TypeIndex -> IO ()+addTypeRef (getConn -> conn) hf arr ixs sp = go 0+ where+ sl = srcSpanStartLine sp+ sc = srcSpanStartCol sp+ el = srcSpanEndLine sp+ ec = srcSpanEndCol sp+ go :: TypeIndex -> Int -> IO ()+ go d 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)+ 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]+ HFunTy a b -> mapM_ next [a,b]+ HQualTy a b -> mapM_ next [a,b]+ HLitTy _ -> pure ()+ HCastTy a -> next a+ HCoercionTy -> pure ()++makeNc :: IO NameCache+makeNc = do+ uniq_supply <- mkSplitUniqSupply 'z'+ return $ initNameCache uniq_supply []++-- | Recursively search for @.hie@ and @.hie-boot@ files in given directory+getHieFilesIn :: FilePath -> IO [FilePath]+getHieFilesIn path = do+ isFile <- doesFileExist path+ if isFile && ("hie" `isExtensionOf` path || "hie-boot" `isExtensionOf` path) then do+ path' <- canonicalizePath path+ return [path']+ else do+ isDir <- doesDirectoryExist path+ if isDir then do+ cnts <- listDirectory path+ withCurrentDirectory path $ foldMap getHieFilesIn cnts+ else+ return []++withHieFile :: (NameCacheMonad m, MonadIO m)+ => FilePath+ -> (HieFile -> m a)+ -> m a+withHieFile path act = do+ ncu <- getNcUpdater+ hiefile <- liftIO $ readHieFile ncu path+ act (hie_file_result hiefile)++-- | Given the path to a HieFile, it tries to find the SrcSpan of an External name in+-- it by loading it and then looking for the name in NameCache+findDefInFile :: OccName -> Module -> FilePath -> IO (Either HieDbErr (RealSrcSpan,Module))+findDefInFile occ mdl file = do+ ncr <- newIORef =<< makeNc+ _ <- runDbM ncr $ withHieFile file (const $ return ())+ nc <- readIORef ncr+ return $ case lookupOrigNameCache (nsNames nc) mdl occ of+ Just name -> case nameSrcSpan name of+ RealSrcSpan sp -> Right (sp, mdl)+ UnhelpfulSpan msg -> Left $ NameUnhelpfulSpan name (FS.unpackFS msg)+ Nothing -> Left $ NameNotFound occ (Just $ moduleName mdl) (Just $ moduleUnitId mdl)++pointCommand :: HieFile -> (Int, Int) -> Maybe (Int, Int) -> (HieAST TypeIndex -> a) -> [a]+pointCommand hf (sl,sc) mep k =+ M.elems $ flip M.mapMaybeWithKey (getAsts $ hie_asts hf) $ \fs ast ->+ k <$> selectSmallestContaining (sp fs) ast+ where+ sloc fs = mkRealSrcLoc fs sl sc+ eloc fs = case mep of+ Nothing -> sloc fs+ Just (el,ec) -> mkRealSrcLoc fs el ec+ sp fs = mkRealSrcSpan (sloc fs) (eloc fs)++dynFlagsForPrinting :: LibDir -> IO DynFlags+dynFlagsForPrinting (LibDir libdir) = do+ systemSettings <- initSysTools+#if __GLASGOW_HASKELL__ >= 808+ libdir+#else+ (Just libdir)+#endif+#if __GLASGOW_HASKELL__ >= 810+ return $ defaultDynFlags systemSettings $ LlvmConfig [] []+#else+ return $ defaultDynFlags systemSettings ([], [])+#endif++isCons :: String -> Bool+isCons (':':_) = True+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+ where+ flat = concatMap (\(a,xs) -> map (a,) xs)+ genRows = foldMap go+ go = bimap maybeToList maybeToList . (goRef &&& goDec)++ goRef (Right name, (sp,_))+ | Just mod <- nameModule_maybe name = Just $+ RefRow path occ (moduleName mod) (moduleUnitId mod) sl sc el ec+ where+ occ = nameOccName name+ sl = srcSpanStartLine sp+ sc = srcSpanStartCol sp+ el = srcSpanEndLine sp+ ec = srcSpanEndCol sp+ goRef _ = Nothing++ goDec (Right name,(_,dets))+ | Just mod <- nameModule_maybe name+ , mod == smdl+ , occ <- nameOccName name+ , info <- identInfo dets+ , Just sp <- getBindSpan info+ , is_root <- isRoot info+ , sl <- srcSpanStartLine sp+ , sc <- srcSpanStartCol sp+ , el <- srcSpanEndLine sp+ , ec <- srcSpanEndCol sp+ = Just $ DeclRow path occ sl sc el ec is_root+ goDec _ = Nothing++ isRoot = any (\case+ ValBind InstanceBind _ _ -> True+ Decl _ _ -> True+ _ -> False)++ getBindSpan = getFirst . foldMap (First . goDecl)+ goDecl (ValBind _ _ sp) = sp+ goDecl (PatternBind _ _ sp) = sp+ goDecl (Decl _ sp) = sp+ goDecl (RecField _ sp) = sp+ goDecl _ = Nothing++genDefRow :: FilePath -> Module -> M.Map Identifier [(Span, IdentifierDetails a)] -> [DefRow]+genDefRow path smod refmap = genRows $ M.toList refmap+ where+ genRows = mapMaybe go+ getSpan name dets+ | RealSrcSpan sp <- nameSrcSpan name = Just sp+ | otherwise = do+ (sp, _dets) <- find defSpan dets+ pure sp++ defSpan = any isDef . identInfo . snd+ isDef (ValBind RegularBind _ _) = True+ isDef PatternBind{} = True+ isDef Decl{} = True+ isDef _ = False++ go (Right name,dets)+ | Just mod <- nameModule_maybe name+ , mod == smod+ , occ <- nameOccName name+ , Just sp <- getSpan name dets+ , sl <- srcSpanStartLine sp+ , sc <- srcSpanStartCol sp+ , el <- srcSpanEndLine sp+ , ec <- srcSpanEndCol sp+ = Just $ DefRow path occ sl sc el ec+ go _ = Nothing++identifierTree :: HieTypes.HieAST a -> Data.Tree.Tree ( HieTypes.HieAST a )+identifierTree HieTypes.Node{ nodeInfo, nodeSpan, nodeChildren } =+ Data.Tree.Node+ { rootLabel = HieTypes.Node{ nodeInfo, nodeSpan, nodeChildren = mempty }+ , subForest = map identifierTree nodeChildren+ }
+ test/Main.hs view
@@ -0,0 +1,253 @@+module Main where++import GHC.Paths (libdir)+import HieDb (HieDb, HieModuleRow (..), LibDir (..), ModuleInfo (..), withHieDb)+import HieDb.Query (getAllIndexedMods, lookupHieFile, resolveUnitId)+import HieDb.Run (Command (..), Options (..), runCommand)+import HieDb.Types (HieDbErr (..))+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 Test.Hspec (Expectation, Spec, afterAll_, around, beforeAll_, describe, hspec, it, runIO,+ shouldBe, shouldEndWith)+import Test.Orphans ()++main :: IO ()+main = hspec spec++spec :: Spec+spec =+ describe "hiedb" $+ beforeAll_ compileTestModules $+ afterAll_ cleanTestData $ do+ cliSpec+ apiSpec++apiSpec :: Spec+apiSpec = describe "api" $+ beforeAll_ (runCommandTest (Index [testTmp])) $+ around withTestDb $+ describe "HieDb.Query" $ do++ describe "getAllIndexedMods" $ do+ it "returns all indexed modules" $ \conn -> do+ mods <- getAllIndexedMods conn+ case mods of+ [m1,m2] -> do+ moduleNameString (modInfoName (hieModInfo m1)) `shouldBe` "Sub.Module2"+ moduleNameString (modInfoName (hieModInfo m2)) `shouldBe` "Module1"+ xs -> fail $ "Was expecting 2 modules, but got " <> show (length xs)++ describe "resolveUnitId" $ do+ it "resolves unit when module unambiguous" $ \conn -> do+ res <- resolveUnitId conn (mkModuleName "Module1")+ case res of+ Left e -> fail $ "Unexpected error: " <> show e+ Right unitId -> unitId `shouldBe` stringToUnitId "main"++ it "returns NotIndexed error on not-indexed module" $ \conn -> do+ let notIndexedModule = mkModuleName "NotIndexed"+ res <- resolveUnitId conn notIndexedModule+ case res of+ Left (NotIndexed modName Nothing) -> modName `shouldBe` notIndexedModule+ Left e -> fail $ "Unexpected error: " <> show e+ Right unitId -> fail $ "Unexpected success: " <> show unitId++ describe "lookupHieFile" $ do+ it "Should lookup indexed Module" $ \conn -> do+ let modName = mkModuleName "Module1"+ res <- lookupHieFile conn modName (stringToUnitId "main")+ case res of+ Just modRow -> do+ hieModuleHieFile modRow `shouldEndWith` "Module1.hie"+ let modInfo = hieModInfo modRow+ modInfoIsReal modInfo `shouldBe` False+ modInfoName modInfo `shouldBe` modName+ Nothing -> fail "Should have looked up indexed file"+ it "Should return Nothing for not indexed Module" $ \conn -> do+ res <- lookupHieFile conn (mkModuleName "NotIndexed") (stringToUnitId "main")+ case res of+ Nothing -> pure ()+ Just _ -> fail "Lookup suceeded unexpectedly"+++cliSpec :: Spec+cliSpec =+ -- TODO commands not covered: init, type-refs, ref-graph, dump, reachable, unreachable, html+ describe "Command line" $ do+ describe "index" $+ it "indexes testing project .hie files" $ do+ runHieDbCli ["index", testTmp, "--quiet"]+ `suceedsWithStdin` ""++ describe "ls" $+ it "lists the indexed modules" $ do+ cwd <- getCurrentDirectory+ let expectedOutput = unlines (fmap (\x -> cwd </> testTmp </> x)+ [ "Sub/Module2.hie\tSub.Module2\tmain"+ , "Module1.hie\tModule1\tmain"+ ])+ runHieDbCli ["ls"] `suceedsWithStdin` expectedOutput++ describe "name-refs" $+ it "lists all references of given function" $ do+ runHieDbCli ["name-refs", "function2"]+ `suceedsWithStdin` unlines+ [ "Module1:3:7-3:16"+ , "Module1:12:1-12:10"+ , "Module1:13:1-13:10"+ ]++ describe "point-refs" $+ 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: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"]+ `suceedsWithStdin` unlines+ [ "Name String at (8,21) is used in:"+ , "Sub.Module2:6:19-6:25"+ , "Module1:8:21-8:27"+ ]+ it "Give no output at point when there's not Type" $+ runHieDbCli ["point-refs", "Module1", "7", "1"]+ `suceedsWithStdin` ""++ 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"+ ]+ 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 the difinition can't be found" $ do+ (exitCode, actualStdout, _) <- runHieDbCli ["point-defs", "Module1", "13", "24"]+ exitCode `shouldBe` ExitFailure 1+ actualStdout `shouldBe` "Couldn't find name: $ from module GHC.Base(base)\n"++ describe "point-info" $+ it "gives information about symbol at specified location" $+ runHieDbCli ["point-info", "Sub.Module2", "10", "10"]+ `suceedsWithStdin` unlines+ [ "Span: test/data/Sub/Module2.hs:10:7-23"+ , "Constructors: {(ConDeclH98, ConDecl)}"+ , "Identifiers:"+ , "Symbol:c:Data1Constructor1:Sub.Module2:main"+ , "Data1Constructor1 defined at test/data/Sub/Module2.hs:10:7-23"+ , " IdentifierDetails Nothing {Decl ConDec (Just SrcSpanOneLine \"test/data/Sub/Module2.hs\" 10 7 24)}"+ , "Types:\n"+ ]++ describe "name-def" $+ it "lookup definition of name" $+ runHieDbCli ["name-def", "showInt"]+ `suceedsWithStdin` "Sub.Module2:7:1-7:8\n"++ describe "type-def" $+ it "lookup definition of type" $+ runHieDbCli ["type-def", "Data1"]+ `suceedsWithStdin` "Sub.Module2:9:1-11:28\n"++ describe "cat" $+ describe "dumps module source stored in .hie file" $ do+ module1Src <- runIO . readFile $ "test" </> "data" </> "Module1.hs"+ it "when given --hiefile" $ do+ cwd <- getCurrentDirectory+ runHieDbCli ["cat", "--hiefile" , cwd </> testTmp </> "Module1.hie"]+ `suceedsWithStdin` (module1Src <> "\n")+ it "when given module name" $+ runHieDbCli ["cat", "Module1"]+ `suceedsWithStdin` (module1Src <> "\n")++ describe "lookup-hie" $+ it "looks up location of .hie file" $ do+ cwd <- getCurrentDirectory+ runHieDbCli ["lookup-hie", "Module1"]+ `suceedsWithStdin` (cwd </> testTmp </> "Module1.hie\n")++ describe "module-uids" $+ it "lists uids for given module" $+ runHieDbCli ["module-uids", "Module1"]+ `suceedsWithStdin` "main\n"+ + describe "rm" $+ it "removes given module from DB" $ do+ runHieDbCli ["rm", "Module1"]+ `suceedsWithStdin` ""+ -- Check with 'ls' comand that there's just one module left+ cwd <- getCurrentDirectory+ runHieDbCli ["ls"] `suceedsWithStdin` (cwd </> testTmp </> "Sub/Module2.hie\tSub.Module2\tmain\n")+ +++suceedsWithStdin :: IO (ExitCode, String, String) -> String -> Expectation+suceedsWithStdin action expectedStdin = do+ (exitCode, actualStdin, actualStdErr) <- action+ exitCode `shouldBe` ExitSuccess+ actualStdErr `shouldBe` ""+ actualStdin `shouldBe` expectedStdin+++runHieDbCli :: [String] -> IO (ExitCode, String, String)+runHieDbCli args = do+ hiedb <- findHieDbExecutable+ let argsWithTestDb = "--database" : testDb : args+ let createProc = proc hiedb argsWithTestDb+ putStrLn $ unwords $ "RUNNING: hiedb" : argsWithTestDb+ readCreateProcessWithExitCode createProc ""+++findHieDbExecutable :: IO FilePath+findHieDbExecutable =+ maybe (die "Did not find hiedb executable") pure =<< findExecutable "hiedb"+++cleanTestData :: IO ()+cleanTestData = removeDirectoryRecursive testTmp++compileTestModules :: IO ()+compileTestModules =+ callProcess "ghc" $+ "-fno-code" : -- don't produce unnecessary .o and .hi files+ "-fwrite-ide-info" :+ "-hiedir=" <> testTmp :+ testModules+++testModules :: [FilePath]+testModules = fmap (\m -> "test" </> "data"</> m)+ [ "Module1.hs"+ , "Sub" </> "Module2.hs"+ ]++testDb :: FilePath+testDb = testTmp </> "test.hiedb"++testTmp :: FilePath+testTmp = "test" </> "tmp"++withTestDb :: (HieDb -> IO a) -> IO a+withTestDb = withHieDb testDb++runCommandTest :: Command -> IO ()+runCommandTest = runCommand (LibDir libdir) testOpts++testOpts :: Options+testOpts = Options+ { database = testDb+ , trace = False+ , quiet = True+ , virtualFile = False+ }
+ test/Test/Orphans.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Test.Orphans where++import HieDb.Types+import Module (ModuleName, moduleName, moduleNameString, moduleUnitId)+import Name (Name, nameModule, nameOccName)+import OccName (OccName, occNameString)++instance Show ModuleName where show = moduleNameString+instance Show OccName where show = occNameString+instance Show Name where+ show n =+ let occ = nameOccName n+ mod' = nameModule n+ mn = moduleName mod'+ uid = moduleUnitId mod'+ in show uid <> ":" <> show mn <> ":" <> show occ++deriving instance Show HieDbErr