diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for hiedb + +## 0.1.0.0 -- 2020-11-08 + +* First version. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/exe/Main.hs b/exe/Main.hs new file mode 100644 --- /dev/null +++ b/exe/Main.hs @@ -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) diff --git a/hiedb.cabal b/hiedb.cabal new file mode 100644 --- /dev/null +++ b/hiedb.cabal @@ -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 diff --git a/src/HieDb.hs b/src/HieDb.hs new file mode 100644 --- /dev/null +++ b/src/HieDb.hs @@ -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 + diff --git a/src/HieDb/Create.hs b/src/HieDb/Create.hs new file mode 100644 --- /dev/null +++ b/src/HieDb/Create.hs @@ -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) diff --git a/src/HieDb/Dump.hs b/src/HieDb/Dump.hs new file mode 100644 --- /dev/null +++ b/src/HieDb/Dump.hs @@ -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 diff --git a/src/HieDb/Html.hs b/src/HieDb/Html.hs new file mode 100644 --- /dev/null +++ b/src/HieDb/Html.hs @@ -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) diff --git a/src/HieDb/Query.hs b/src/HieDb/Query.hs new file mode 100644 --- /dev/null +++ b/src/HieDb/Query.hs @@ -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) diff --git a/src/HieDb/Run.hs b/src/HieDb/Run.hs new file mode 100644 --- /dev/null +++ b/src/HieDb/Run.hs @@ -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 +hiedb index [...] [hiedb] +hiedb name-refs [unitid] [hiedb] +hiedb type-refs [unitid] [hiedb] +hiedb query-pos [hiedb] +hiedb query-pos --hiedir= [hiedb] +hiedb cat [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) + ] diff --git a/src/HieDb/Types.hs b/src/HieDb/Types.hs new file mode 100644 --- /dev/null +++ b/src/HieDb/Types.hs @@ -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 +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) diff --git a/src/HieDb/Utils.hs b/src/HieDb/Utils.hs new file mode 100644 --- /dev/null +++ b/src/HieDb/Utils.hs @@ -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 + } diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 + } diff --git a/test/Test/Orphans.hs b/test/Test/Orphans.hs new file mode 100644 --- /dev/null +++ b/test/Test/Orphans.hs @@ -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