{-# 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 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.Compat
import HieDb.Types
import HieDb.Utils
import qualified HieDb.Html as Html
getAllIndexedMods :: HieDb -> IO [HieModuleRow]
getAllIndexedMods :: HieDb -> IO [HieModuleRow]
getAllIndexedMods (HieDb -> Connection
getConn -> Connection
conn) = Connection -> Query -> IO [HieModuleRow]
forall r. FromRow r => Connection -> Query -> IO [r]
query_ Connection
conn Query
"SELECT * FROM mods"
getAllIndexedExports :: HieDb -> IO [(ExportRow)]
getAllIndexedExports :: HieDb -> IO [ExportRow]
getAllIndexedExports (HieDb -> Connection
getConn -> Connection
conn) = Connection -> Query -> IO [ExportRow]
forall r. FromRow r => Connection -> Query -> IO [r]
query_ Connection
conn Query
"SELECT * FROM exports"
getExportsForModule :: HieDb -> ModuleName -> IO [ExportRow]
getExportsForModule :: HieDb -> ModuleName -> IO [ExportRow]
getExportsForModule (HieDb -> Connection
getConn -> Connection
conn) ModuleName
mn =
Connection -> Query -> Only ModuleName -> IO [ExportRow]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query Connection
conn Query
"SELECT exports.* FROM exports JOIN mods USING (hieFile) WHERE mods.mod = ?" (ModuleName -> Only ModuleName
forall a. a -> Only a
Only ModuleName
mn)
findExporters :: HieDb -> OccName -> ModuleName -> Unit -> IO [ModuleName]
findExporters :: HieDb -> OccName -> ModuleName -> Unit -> IO [ModuleName]
findExporters (HieDb -> Connection
getConn -> Connection
conn) OccName
occ ModuleName
mn Unit
unit =
Connection
-> Query -> (OccName, ModuleName, Unit) -> IO [ModuleName]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query Connection
conn Query
"SELECT mods.mod FROM exports JOIN mods USING (hieFile) WHERE occ = ? AND mod = ? AND unit = ?" (OccName
occ, ModuleName
mn, Unit
unit)
resolveUnitId :: HieDb -> ModuleName -> IO (Either HieDbErr Unit)
resolveUnitId :: HieDb -> ModuleName -> IO (Either HieDbErr Unit)
resolveUnitId (HieDb -> Connection
getConn -> Connection
conn) ModuleName
mn = do
[ModuleInfo]
luid <- Connection -> Query -> Only ModuleName -> IO [ModuleInfo]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query Connection
conn Query
"SELECT mod, unit, is_boot, hs_src, is_real, hash FROM mods WHERE mod = ? and is_boot = 0" (ModuleName -> Only ModuleName
forall a. a -> Only a
Only ModuleName
mn)
Either HieDbErr Unit -> IO (Either HieDbErr Unit)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either HieDbErr Unit -> IO (Either HieDbErr Unit))
-> Either HieDbErr Unit -> IO (Either HieDbErr Unit)
forall a b. (a -> b) -> a -> b
$ case [ModuleInfo]
luid of
[] -> HieDbErr -> Either HieDbErr Unit
forall a b. a -> Either a b
Left (HieDbErr -> Either HieDbErr Unit)
-> HieDbErr -> Either HieDbErr Unit
forall a b. (a -> b) -> a -> b
$ ModuleName -> Maybe Unit -> HieDbErr
NotIndexed ModuleName
mn Maybe Unit
forall a. Maybe a
Nothing
[ModuleInfo
x] -> Unit -> Either HieDbErr Unit
forall a b. b -> Either a b
Right (Unit -> Either HieDbErr Unit) -> Unit -> Either HieDbErr Unit
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> Unit
modInfoUnit ModuleInfo
x
(ModuleInfo
x:[ModuleInfo]
xs) -> HieDbErr -> Either HieDbErr Unit
forall a b. a -> Either a b
Left (HieDbErr -> Either HieDbErr Unit)
-> HieDbErr -> Either HieDbErr Unit
forall a b. (a -> b) -> a -> b
$ NonEmpty ModuleInfo -> HieDbErr
AmbiguousUnitId (NonEmpty ModuleInfo -> HieDbErr)
-> NonEmpty ModuleInfo -> HieDbErr
forall a b. (a -> b) -> a -> b
$ ModuleInfo
x ModuleInfo -> [ModuleInfo] -> NonEmpty ModuleInfo
forall a. a -> [a] -> NonEmpty a
:| [ModuleInfo]
xs
findReferences :: HieDb -> Bool -> OccName -> Maybe ModuleName -> Maybe Unit -> [FilePath] -> IO [Res RefRow]
findReferences :: HieDb
-> Bool
-> OccName
-> Maybe ModuleName
-> Maybe Unit
-> [FilePath]
-> IO [Res RefRow]
findReferences (HieDb -> Connection
getConn -> Connection
conn) Bool
isReal OccName
occ Maybe ModuleName
mn Maybe Unit
uid [FilePath]
exclude =
Connection -> Query -> [NamedParam] -> IO [Res RefRow]
forall r.
FromRow r =>
Connection -> Query -> [NamedParam] -> IO [r]
queryNamed Connection
conn Query
thisQuery ([Text
":occ" Text -> OccName -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= OccName
occ, Text
":mod" Text -> Maybe ModuleName -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= Maybe ModuleName
mn, Text
":unit" Text -> Maybe Unit -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= Maybe Unit
uid, Text
":real" Text -> Bool -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= Bool
isReal] [NamedParam] -> [NamedParam] -> [NamedParam]
forall a. [a] -> [a] -> [a]
++ [NamedParam]
excludedFields)
where
excludedFields :: [NamedParam]
excludedFields = (Int -> FilePath -> NamedParam)
-> [Int] -> [FilePath] -> [NamedParam]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
n FilePath
f -> (Text
":exclude" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show Int
n)) Text -> FilePath -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= FilePath
f) [Int
1 :: Int ..] [FilePath]
exclude
thisQuery :: Query
thisQuery =
Query
"SELECT refs.*,mods.mod,mods.unit,mods.is_boot,mods.hs_src,mods.is_real,mods.hash \
\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))"
Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Query
" AND mods.hs_src NOT IN (" Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Text -> Query
Query (Text -> [Text] -> Text
T.intercalate Text
"," ((NamedParam -> Text) -> [NamedParam] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
l := v
_) -> Text
l) [NamedParam]
excludedFields)) Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Query
")"
lookupHieFile :: HieDb -> ModuleName -> Unit -> IO (Maybe HieModuleRow)
lookupHieFile :: HieDb -> ModuleName -> Unit -> IO (Maybe HieModuleRow)
lookupHieFile (HieDb -> Connection
getConn -> Connection
conn) ModuleName
mn Unit
uid = do
[HieModuleRow]
files <- Connection -> Query -> (ModuleName, Unit) -> IO [HieModuleRow]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query Connection
conn Query
"SELECT * FROM mods WHERE mod = ? AND unit = ? AND is_boot = 0" (ModuleName
mn, Unit
uid)
case [HieModuleRow]
files of
[] -> Maybe HieModuleRow -> IO (Maybe HieModuleRow)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe HieModuleRow
forall a. Maybe a
Nothing
[HieModuleRow
x] -> Maybe HieModuleRow -> IO (Maybe HieModuleRow)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe HieModuleRow -> IO (Maybe HieModuleRow))
-> Maybe HieModuleRow -> IO (Maybe HieModuleRow)
forall a b. (a -> b) -> a -> b
$ HieModuleRow -> Maybe HieModuleRow
forall a. a -> Maybe a
Just HieModuleRow
x
[HieModuleRow]
xs ->
FilePath -> IO (Maybe HieModuleRow)
forall a. HasCallStack => FilePath -> a
error (FilePath -> IO (Maybe HieModuleRow))
-> FilePath -> IO (Maybe HieModuleRow)
forall a b. (a -> b) -> a -> b
$ FilePath
"DB invariant violated, (mod,unit) in mods not unique: "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (FilePath, Unit) -> FilePath
forall a. Show a => a -> FilePath
show (ModuleName -> FilePath
moduleNameString ModuleName
mn, Unit
uid) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
". Entries: "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", " ((HieModuleRow -> FilePath) -> [HieModuleRow] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map HieModuleRow -> FilePath
hieModuleHieFile [HieModuleRow]
xs)
lookupHieFileFromSource :: HieDb -> FilePath -> IO (Maybe HieModuleRow)
lookupHieFileFromSource :: HieDb -> FilePath -> IO (Maybe HieModuleRow)
lookupHieFileFromSource (HieDb -> Connection
getConn -> Connection
conn) FilePath
fp = do
[HieModuleRow]
files <- Connection -> Query -> Only FilePath -> IO [HieModuleRow]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query Connection
conn Query
"SELECT * FROM mods WHERE hs_src = ?" (FilePath -> Only FilePath
forall a. a -> Only a
Only FilePath
fp)
case [HieModuleRow]
files of
[] -> Maybe HieModuleRow -> IO (Maybe HieModuleRow)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe HieModuleRow
forall a. Maybe a
Nothing
[HieModuleRow
x] -> Maybe HieModuleRow -> IO (Maybe HieModuleRow)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe HieModuleRow -> IO (Maybe HieModuleRow))
-> Maybe HieModuleRow -> IO (Maybe HieModuleRow)
forall a b. (a -> b) -> a -> b
$ HieModuleRow -> Maybe HieModuleRow
forall a. a -> Maybe a
Just HieModuleRow
x
[HieModuleRow]
xs ->
FilePath -> IO (Maybe HieModuleRow)
forall a. HasCallStack => FilePath -> a
error (FilePath -> IO (Maybe HieModuleRow))
-> FilePath -> IO (Maybe HieModuleRow)
forall a b. (a -> b) -> a -> b
$ FilePath
"DB invariant violated, hs_src in mods not unique: "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
fp FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
". Entries: "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", " ((HieModuleRow -> FilePath) -> [HieModuleRow] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map ([SQLData] -> FilePath
forall a. Show a => a -> FilePath
show ([SQLData] -> FilePath)
-> (HieModuleRow -> [SQLData]) -> HieModuleRow -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HieModuleRow -> [SQLData]
forall a. ToRow a => a -> [SQLData]
toRow) [HieModuleRow]
xs)
findTypeRefs :: HieDb -> Bool -> OccName -> Maybe ModuleName -> Maybe Unit -> [FilePath] -> IO [Res TypeRef]
findTypeRefs :: HieDb
-> Bool
-> OccName
-> Maybe ModuleName
-> Maybe Unit
-> [FilePath]
-> IO [Res TypeRef]
findTypeRefs (HieDb -> Connection
getConn -> Connection
conn) Bool
isReal OccName
occ Maybe ModuleName
mn Maybe Unit
uid [FilePath]
exclude
= Connection -> Query -> [NamedParam] -> IO [Res TypeRef]
forall r.
FromRow r =>
Connection -> Query -> [NamedParam] -> IO [r]
queryNamed Connection
conn Query
thisQuery ([Text
":occ" Text -> OccName -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= OccName
occ, Text
":mod" Text -> Maybe ModuleName -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= Maybe ModuleName
mn, Text
":unit" Text -> Maybe Unit -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= Maybe Unit
uid, Text
":real" Text -> Bool -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= Bool
isReal] [NamedParam] -> [NamedParam] -> [NamedParam]
forall a. [a] -> [a] -> [a]
++ [NamedParam]
excludedFields)
where
excludedFields :: [NamedParam]
excludedFields = (Int -> FilePath -> NamedParam)
-> [Int] -> [FilePath] -> [NamedParam]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
n FilePath
f -> (Text
":exclude" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show Int
n)) Text -> FilePath -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= FilePath
f) [Int
1 :: Int ..] [FilePath]
exclude
thisQuery :: Query
thisQuery =
Query
"SELECT typerefs.*, mods.mod,mods.unit,mods.is_boot,mods.hs_src,mods.is_real,mods.hash \
\FROM typerefs JOIN mods ON typerefs.hieFile = mods.hieFile \
\JOIN typenames ON typerefs.id = typenames.id \
\WHERE typenames.name = :occ AND (:mod IS NULL OR typenames.mod = :mod) AND \
\(:unit IS NULL OR typenames.unit = :unit) AND ((NOT :real) OR (mods.is_real AND mods.hs_src IS NOT NULL))"
Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Query
" AND mods.hs_src NOT IN (" Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Text -> Query
Query (Text -> [Text] -> Text
T.intercalate Text
"," ((NamedParam -> Text) -> [NamedParam] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
l := v
_) -> Text
l) [NamedParam]
excludedFields)) Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Query
")"
Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> Query
" ORDER BY typerefs.depth ASC"
findDef :: HieDb -> OccName -> Maybe ModuleName -> Maybe Unit -> IO [Res DefRow]
findDef :: HieDb
-> OccName -> Maybe ModuleName -> Maybe Unit -> IO [Res DefRow]
findDef HieDb
conn OccName
occ Maybe ModuleName
mn Maybe Unit
uid
= Connection -> Query -> [NamedParam] -> IO [Res DefRow]
forall r.
FromRow r =>
Connection -> Query -> [NamedParam] -> IO [r]
queryNamed (HieDb -> Connection
getConn HieDb
conn) Query
"SELECT defs.*, mods.mod,mods.unit,mods.is_boot,mods.hs_src,mods.is_real,mods.hash \
\FROM defs JOIN mods USING (hieFile) \
\WHERE occ = :occ AND (:mod IS NULL OR mod = :mod) AND (:unit IS NULL OR unit = :unit)"
[Text
":occ" Text -> OccName -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= OccName
occ,Text
":mod" Text -> Maybe ModuleName -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= Maybe ModuleName
mn, Text
":unit" Text -> Maybe Unit -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= Maybe Unit
uid]
findOneDef :: HieDb -> OccName -> Maybe ModuleName -> Maybe Unit -> IO (Either HieDbErr (Res DefRow))
findOneDef :: HieDb
-> OccName
-> Maybe ModuleName
-> Maybe Unit
-> IO (Either HieDbErr (Res DefRow))
findOneDef HieDb
conn OccName
occ Maybe ModuleName
mn Maybe Unit
muid = [Res DefRow] -> Either HieDbErr (Res DefRow)
forall h. [h :. ModuleInfo] -> Either HieDbErr (h :. ModuleInfo)
wrap ([Res DefRow] -> Either HieDbErr (Res DefRow))
-> IO [Res DefRow] -> IO (Either HieDbErr (Res DefRow))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HieDb
-> OccName -> Maybe ModuleName -> Maybe Unit -> IO [Res DefRow]
findDef HieDb
conn OccName
occ Maybe ModuleName
mn Maybe Unit
muid
where
wrap :: [h :. ModuleInfo] -> Either HieDbErr (h :. ModuleInfo)
wrap [h :. ModuleInfo
x] = (h :. ModuleInfo) -> Either HieDbErr (h :. ModuleInfo)
forall a b. b -> Either a b
Right h :. ModuleInfo
x
wrap [] = HieDbErr -> Either HieDbErr (h :. ModuleInfo)
forall a b. a -> Either a b
Left (HieDbErr -> Either HieDbErr (h :. ModuleInfo))
-> HieDbErr -> Either HieDbErr (h :. ModuleInfo)
forall a b. (a -> b) -> a -> b
$ OccName -> Maybe ModuleName -> Maybe Unit -> HieDbErr
NameNotFound OccName
occ Maybe ModuleName
mn Maybe Unit
muid
wrap (h :. ModuleInfo
x:[h :. ModuleInfo]
xs) = HieDbErr -> Either HieDbErr (h :. ModuleInfo)
forall a b. a -> Either a b
Left (HieDbErr -> Either HieDbErr (h :. ModuleInfo))
-> HieDbErr -> Either HieDbErr (h :. ModuleInfo)
forall a b. (a -> b) -> a -> b
$ NonEmpty ModuleInfo -> HieDbErr
AmbiguousUnitId ((h :. ModuleInfo) -> ModuleInfo
forall h t. (h :. t) -> t
defUnit h :. ModuleInfo
x ModuleInfo -> [ModuleInfo] -> NonEmpty ModuleInfo
forall a. a -> [a] -> NonEmpty a
:| ((h :. ModuleInfo) -> ModuleInfo)
-> [h :. ModuleInfo] -> [ModuleInfo]
forall a b. (a -> b) -> [a] -> [b]
map (h :. ModuleInfo) -> ModuleInfo
forall h t. (h :. t) -> t
defUnit [h :. ModuleInfo]
xs)
defUnit :: (h :. t) -> t
defUnit (h
_:.t
i) = t
i
searchDef :: HieDb -> String -> IO [Res DefRow]
searchDef :: HieDb -> FilePath -> IO [Res DefRow]
searchDef HieDb
conn FilePath
cs
= Connection -> Query -> Only FilePath -> IO [Res DefRow]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query (HieDb -> Connection
getConn HieDb
conn) Query
"SELECT defs.*,mods.mod,mods.unit,mods.is_boot,mods.hs_src,mods.is_real,mods.hash \
\FROM defs JOIN mods USING (hieFile) \
\WHERE occ LIKE ? \
\LIMIT 200" (FilePath -> Only FilePath
forall a. a -> Only a
Only (FilePath -> Only FilePath) -> FilePath -> Only FilePath
forall a b. (a -> b) -> a -> b
$ Char
'_'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath
csFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
"%")
withTarget
:: HieDb
-> HieTarget
-> (HieFile -> a)
-> IO (Either HieDbErr a)
withTarget :: HieDb -> HieTarget -> (HieFile -> a) -> IO (Either HieDbErr a)
withTarget HieDb
conn HieTarget
target HieFile -> a
f = case HieTarget
target of
Left FilePath
fp -> FilePath -> IO (Either HieDbErr a)
forall a. FilePath -> IO (Either a a)
processHieFile FilePath
fp
Right (ModuleName
mn,Maybe Unit
muid) -> do
Either HieDbErr Unit
euid <- IO (Either HieDbErr Unit)
-> (Unit -> IO (Either HieDbErr Unit))
-> Maybe Unit
-> IO (Either HieDbErr Unit)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (HieDb -> ModuleName -> IO (Either HieDbErr Unit)
resolveUnitId HieDb
conn ModuleName
mn) (Either HieDbErr Unit -> IO (Either HieDbErr Unit)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either HieDbErr Unit -> IO (Either HieDbErr Unit))
-> (Unit -> Either HieDbErr Unit)
-> Unit
-> IO (Either HieDbErr Unit)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unit -> Either HieDbErr Unit
forall a b. b -> Either a b
Right) Maybe Unit
muid
case Either HieDbErr Unit
euid of
Left HieDbErr
err -> Either HieDbErr a -> IO (Either HieDbErr a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either HieDbErr a -> IO (Either HieDbErr a))
-> Either HieDbErr a -> IO (Either HieDbErr a)
forall a b. (a -> b) -> a -> b
$ HieDbErr -> Either HieDbErr a
forall a b. a -> Either a b
Left HieDbErr
err
Right Unit
uid -> do
Maybe HieModuleRow
mModRow <- HieDb -> ModuleName -> Unit -> IO (Maybe HieModuleRow)
lookupHieFile HieDb
conn ModuleName
mn Unit
uid
case Maybe HieModuleRow
mModRow of
Maybe HieModuleRow
Nothing -> Either HieDbErr a -> IO (Either HieDbErr a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either HieDbErr a -> IO (Either HieDbErr a))
-> Either HieDbErr a -> IO (Either HieDbErr a)
forall a b. (a -> b) -> a -> b
$ HieDbErr -> Either HieDbErr a
forall a b. a -> Either a b
Left (ModuleName -> Maybe Unit -> HieDbErr
NotIndexed ModuleName
mn (Maybe Unit -> HieDbErr) -> Maybe Unit -> HieDbErr
forall a b. (a -> b) -> a -> b
$ Unit -> Maybe Unit
forall a. a -> Maybe a
Just Unit
uid)
Just HieModuleRow
modRow -> FilePath -> IO (Either HieDbErr a)
forall a. FilePath -> IO (Either a a)
processHieFile (HieModuleRow -> FilePath
hieModuleHieFile HieModuleRow
modRow)
where
processHieFile :: FilePath -> IO (Either a a)
processHieFile FilePath
fp = do
FilePath
fp' <- FilePath -> IO FilePath
canonicalizePath FilePath
fp
IORef NameCache
nc <- NameCache -> IO (IORef NameCache)
forall a. a -> IO (IORef a)
newIORef (NameCache -> IO (IORef NameCache))
-> IO NameCache -> IO (IORef NameCache)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO NameCache
makeNc
IORef NameCache -> DbMonad (Either a a) -> IO (Either a a)
forall a. IORef NameCache -> DbMonad a -> IO a
runDbM IORef NameCache
nc (DbMonad (Either a a) -> IO (Either a a))
-> DbMonad (Either a a) -> IO (Either a a)
forall a b. (a -> b) -> a -> b
$ do
a -> Either a a
forall a b. b -> Either a b
Right (a -> Either a a) -> DbMonadT IO a -> DbMonad (Either a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> (HieFile -> DbMonadT IO a) -> DbMonadT IO a
forall (m :: * -> *) a.
(NameCacheMonad m, MonadIO m) =>
FilePath -> (HieFile -> m a) -> m a
withHieFile FilePath
fp' (a -> DbMonadT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> DbMonadT IO a) -> (HieFile -> a) -> HieFile -> DbMonadT IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HieFile -> a
f)
type Vertex = (String, String, String, Int, Int, Int, Int)
declRefs :: HieDb -> IO ()
declRefs :: HieDb -> IO ()
declRefs HieDb
db = do
AdjacencyMap Vertex
graph <- HieDb -> IO (AdjacencyMap Vertex)
getGraph HieDb
db
FilePath -> FilePath -> IO ()
writeFile
FilePath
"refs.dot"
( Style Vertex FilePath -> AdjacencyMap Vertex -> FilePath
forall s a g.
(IsString s, Monoid s, Ord a, ToGraph g, ToVertex g ~ a) =>
Style a s -> g -> s
export
( ( (Vertex -> FilePath) -> Style Vertex FilePath
forall s a. Monoid s => (a -> s) -> Style a s
defaultStyle ( \( FilePath
_, FilePath
hie, FilePath
occ, Int
_, Int
_, Int
_, Int
_ ) -> FilePath
hie FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
":" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
occ ) )
{ vertexAttributes :: Vertex -> [Attribute FilePath]
vertexAttributes = \( FilePath
mod', FilePath
_, FilePath
occ, Int
_, Int
_, Int
_, Int
_ ) ->
[ FilePath
"label" FilePath -> FilePath -> Attribute FilePath
forall s. s -> s -> Attribute s
G.:= ( FilePath
mod' FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"." FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop Int
1 FilePath
occ )
, FilePath
"fillcolor" FilePath -> FilePath -> Attribute FilePath
forall s. s -> s -> Attribute s
G.:= case FilePath
occ of (Char
'v':FilePath
_) -> FilePath
"red"; (Char
't':FilePath
_) -> FilePath
"blue";FilePath
_ -> FilePath
"black"
]
}
)
AdjacencyMap Vertex
graph
)
getGraph :: HieDb -> IO (AdjacencyMap Vertex)
getGraph :: HieDb -> IO (AdjacencyMap Vertex)
getGraph (HieDb -> Connection
getConn -> Connection
conn) = do
[Vertex :. Vertex]
es <-
Connection -> Query -> IO [Vertex :. Vertex]
forall r. FromRow r => Connection -> Query -> IO [r]
query_ Connection
conn Query
"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))"
[Vertex]
vs <-
Connection -> Query -> IO [Vertex]
forall r. FromRow r => Connection -> Query -> IO [r]
query_ Connection
conn Query
"SELECT mods.mod, decls.hieFile, decls.occ, decls.sl, decls.sc, decls.el, decls.ec \
\FROM decls JOIN mods USING (hieFile)"
AdjacencyMap Vertex -> IO (AdjacencyMap Vertex)
forall (m :: * -> *) a. Monad m => a -> m a
return (AdjacencyMap Vertex -> IO (AdjacencyMap Vertex))
-> AdjacencyMap Vertex -> IO (AdjacencyMap Vertex)
forall a b. (a -> b) -> a -> b
$ AdjacencyMap Vertex -> AdjacencyMap Vertex -> AdjacencyMap Vertex
forall a.
Ord a =>
AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a
overlay ( [Vertex] -> AdjacencyMap Vertex
forall a. Ord a => [a] -> AdjacencyMap a
vertices [Vertex]
vs ) ( [(Vertex, Vertex)] -> AdjacencyMap Vertex
forall a. Ord a => [(a, a)] -> AdjacencyMap a
edges ( ((Vertex :. Vertex) -> (Vertex, Vertex))
-> [Vertex :. Vertex] -> [(Vertex, Vertex)]
forall a b. (a -> b) -> [a] -> [b]
map (\( Vertex
x :. Vertex
y ) -> ( Vertex
x, Vertex
y )) [Vertex :. Vertex]
es ) )
getVertices :: HieDb -> [Symbol] -> IO [Vertex]
getVertices :: HieDb -> [Symbol] -> IO [Vertex]
getVertices (HieDb -> Connection
getConn -> Connection
conn) [Symbol]
ss = Set Vertex -> [Vertex]
forall a. Set a -> [a]
Set.toList (Set Vertex -> [Vertex]) -> IO (Set Vertex) -> IO [Vertex]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Set Vertex -> Symbol -> IO (Set Vertex))
-> Set Vertex -> [Symbol] -> IO (Set Vertex)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Set Vertex -> Symbol -> IO (Set Vertex)
f Set Vertex
forall a. Set a
Set.empty [Symbol]
ss
where
f :: Set Vertex -> Symbol -> IO (Set Vertex)
f :: Set Vertex -> Symbol -> IO (Set Vertex)
f Set Vertex
vs Symbol
s = (Set Vertex -> Vertex -> Set Vertex)
-> Set Vertex -> [Vertex] -> Set Vertex
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((Vertex -> Set Vertex -> Set Vertex)
-> Set Vertex -> Vertex -> Set Vertex
forall a b c. (a -> b -> c) -> b -> a -> c
flip Vertex -> Set Vertex -> Set Vertex
forall a. Ord a => a -> Set a -> Set a
Set.insert) Set Vertex
vs ([Vertex] -> Set Vertex) -> IO [Vertex] -> IO (Set Vertex)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Symbol -> IO [Vertex]
one Symbol
s
one :: Symbol -> IO [Vertex]
one :: Symbol -> IO [Vertex]
one Symbol
s = do
let n :: FilePath
n = NameSpace -> Char
toNsChar (OccName -> NameSpace
occNameSpace (OccName -> NameSpace) -> OccName -> NameSpace
forall a b. (a -> b) -> a -> b
$ Symbol -> OccName
symName Symbol
s) Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: OccName -> FilePath
occNameString (Symbol -> OccName
symName Symbol
s)
m :: FilePath
m = ModuleName -> FilePath
moduleNameString (ModuleName -> FilePath) -> ModuleName -> FilePath
forall a b. (a -> b) -> a -> b
$ Module -> ModuleName
moduleName (Module -> ModuleName) -> Module -> ModuleName
forall a b. (a -> b) -> a -> b
$ Symbol -> Module
symModule Symbol
s
u :: FilePath
u = Unit -> FilePath
unitString (Module -> Unit
moduleUnit (Module -> Unit) -> Module -> Unit
forall a b. (a -> b) -> a -> b
$ Symbol -> Module
symModule Symbol
s)
Connection
-> Query -> (FilePath, FilePath, FilePath) -> IO [Vertex]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query Connection
conn Query
"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 = ? ) " (FilePath
n, FilePath
m, FilePath
u)
getReachable :: HieDb -> [Symbol] -> IO [Vertex]
getReachable :: HieDb -> [Symbol] -> IO [Vertex]
getReachable HieDb
db [Symbol]
symbols = ([Vertex], [Vertex]) -> [Vertex]
forall a b. (a, b) -> a
fst (([Vertex], [Vertex]) -> [Vertex])
-> IO ([Vertex], [Vertex]) -> IO [Vertex]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HieDb -> [Symbol] -> IO ([Vertex], [Vertex])
getReachableUnreachable HieDb
db [Symbol]
symbols
getUnreachable :: HieDb -> [Symbol] -> IO [Vertex]
getUnreachable :: HieDb -> [Symbol] -> IO [Vertex]
getUnreachable HieDb
db [Symbol]
symbols = ([Vertex], [Vertex]) -> [Vertex]
forall a b. (a, b) -> b
snd (([Vertex], [Vertex]) -> [Vertex])
-> IO ([Vertex], [Vertex]) -> IO [Vertex]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HieDb -> [Symbol] -> IO ([Vertex], [Vertex])
getReachableUnreachable HieDb
db [Symbol]
symbols
html :: (NameCacheMonad m, MonadIO m) => HieDb -> [Symbol] -> m ()
html :: HieDb -> [Symbol] -> m ()
html HieDb
db [Symbol]
symbols = do
Map FilePath (ModuleName, Set Span)
m <- IO (Map FilePath (ModuleName, Set Span))
-> m (Map FilePath (ModuleName, Set Span))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map FilePath (ModuleName, Set Span))
-> m (Map FilePath (ModuleName, Set Span)))
-> IO (Map FilePath (ModuleName, Set Span))
-> m (Map FilePath (ModuleName, Set Span))
forall a b. (a -> b) -> a -> b
$ HieDb -> [Symbol] -> IO (Map FilePath (ModuleName, Set Span))
getAnnotations HieDb
db [Symbol]
symbols
[(FilePath, (ModuleName, Set Span))]
-> ((FilePath, (ModuleName, Set Span)) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map FilePath (ModuleName, Set Span)
-> [(FilePath, (ModuleName, Set Span))]
forall k a. Map k a -> [(k, a)]
Map.toList Map FilePath (ModuleName, Set Span)
m) (((FilePath, (ModuleName, Set Span)) -> m ()) -> m ())
-> ((FilePath, (ModuleName, Set Span)) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(FilePath
fp, (ModuleName
mod', Set Span
sps)) -> do
[Text]
code <- FilePath -> m [Text]
forall (m :: * -> *).
(NameCacheMonad m, MonadIO m) =>
FilePath -> m [Text]
sourceCode FilePath
fp
let fp' :: FilePath
fp' = FilePath -> FilePath -> FilePath
replaceExtension FilePath
fp FilePath
"html"
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ ModuleName -> FilePath
moduleNameString ModuleName
mod' FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
": " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
fp'
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ModuleName -> [Text] -> [Span] -> IO ()
Html.generate FilePath
fp' ModuleName
mod' [Text]
code ([Span] -> IO ()) -> [Span] -> IO ()
forall a b. (a -> b) -> a -> b
$ Set Span -> [Span]
forall a. Set a -> [a]
Set.toList Set Span
sps
getAnnotations :: HieDb -> [Symbol] -> IO (Map FilePath (ModuleName, Set Html.Span))
getAnnotations :: HieDb -> [Symbol] -> IO (Map FilePath (ModuleName, Set Span))
getAnnotations HieDb
db [Symbol]
symbols = do
([Vertex]
rs, [Vertex]
us) <- HieDb -> [Symbol] -> IO ([Vertex], [Vertex])
getReachableUnreachable HieDb
db [Symbol]
symbols
let m1 :: Map FilePath (ModuleName, Set Span)
m1 = (Map FilePath (ModuleName, Set Span)
-> Vertex -> Map FilePath (ModuleName, Set Span))
-> Map FilePath (ModuleName, Set Span)
-> [Vertex]
-> Map FilePath (ModuleName, Set Span)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Color
-> Map FilePath (ModuleName, Set Span)
-> Vertex
-> Map FilePath (ModuleName, Set Span)
f Color
Html.Reachable) Map FilePath (ModuleName, Set Span)
forall k a. Map k a
Map.empty [Vertex]
rs
m2 :: Map FilePath (ModuleName, Set Span)
m2 = (Map FilePath (ModuleName, Set Span)
-> Vertex -> Map FilePath (ModuleName, Set Span))
-> Map FilePath (ModuleName, Set Span)
-> [Vertex]
-> Map FilePath (ModuleName, Set Span)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Color
-> Map FilePath (ModuleName, Set Span)
-> Vertex
-> Map FilePath (ModuleName, Set Span)
f Color
Html.Unreachable) Map FilePath (ModuleName, Set Span)
m1 [Vertex]
us
Map FilePath (ModuleName, Set Span)
-> IO (Map FilePath (ModuleName, Set Span))
forall (m :: * -> *) a. Monad m => a -> m a
return Map FilePath (ModuleName, Set Span)
m2
where
f :: Html.Color
-> Map FilePath (ModuleName, Set Html.Span)
-> Vertex
-> Map FilePath (ModuleName, Set Html.Span)
f :: Color
-> Map FilePath (ModuleName, Set Span)
-> Vertex
-> Map FilePath (ModuleName, Set Span)
f Color
c Map FilePath (ModuleName, Set Span)
m Vertex
v =
let (FilePath
fp, ModuleName
mod', Span
sp) = Color -> Vertex -> (FilePath, ModuleName, Span)
g Color
c Vertex
v
in ((ModuleName, Set Span)
-> (ModuleName, Set Span) -> (ModuleName, Set Span))
-> FilePath
-> (ModuleName, Set Span)
-> Map FilePath (ModuleName, Set Span)
-> Map FilePath (ModuleName, Set Span)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith (ModuleName, Set Span)
-> (ModuleName, Set Span) -> (ModuleName, Set Span)
h FilePath
fp (ModuleName
mod', Span -> Set Span
forall a. a -> Set a
Set.singleton Span
sp) Map FilePath (ModuleName, Set Span)
m
g :: Html.Color -> Vertex -> (FilePath, ModuleName, Html.Span)
g :: Color -> Vertex -> (FilePath, ModuleName, Span)
g Color
c (FilePath
mod', FilePath
fp, FilePath
_, Int
sl, Int
sc, Int
el, Int
ec) = (FilePath
fp, FilePath -> ModuleName
mkModuleName FilePath
mod', Span :: Int -> Int -> Int -> Int -> Color -> Span
Html.Span
{ spStartLine :: Int
Html.spStartLine = Int
sl
, spStartColumn :: Int
Html.spStartColumn = Int
sc
, spEndLine :: Int
Html.spEndLine = Int
el
, spEndColumn :: Int
Html.spEndColumn = Int
ec
, spColor :: Color
Html.spColor = Color
c
})
h :: (ModuleName, Set Html.Span)
-> (ModuleName, Set Html.Span)
-> (ModuleName, Set Html.Span)
h :: (ModuleName, Set Span)
-> (ModuleName, Set Span) -> (ModuleName, Set Span)
h (ModuleName
m, Set Span
sps) (ModuleName
_, Set Span
sps') = (ModuleName
m, Set Span
sps Set Span -> Set Span -> Set Span
forall a. Semigroup a => a -> a -> a
<> Set Span
sps')
getReachableUnreachable :: HieDb -> [Symbol] -> IO ([Vertex], [Vertex])
getReachableUnreachable :: HieDb -> [Symbol] -> IO ([Vertex], [Vertex])
getReachableUnreachable HieDb
db [Symbol]
symbols = do
[Vertex]
vs <- HieDb -> [Symbol] -> IO [Vertex]
getVertices HieDb
db [Symbol]
symbols
AdjacencyMap Vertex
graph <- HieDb -> IO (AdjacencyMap Vertex)
getGraph HieDb
db
let (Set Vertex
xs, Set Vertex
ys) = AdjacencyMap Vertex -> [Vertex] -> (Set Vertex, Set Vertex)
forall a. Ord a => AdjacencyMap a -> [a] -> (Set a, Set a)
splitByReachability AdjacencyMap Vertex
graph [Vertex]
vs
([Vertex], [Vertex]) -> IO ([Vertex], [Vertex])
forall (m :: * -> *) a. Monad m => a -> m a
return (Set Vertex -> [Vertex]
forall a. Set a -> [a]
Set.toList Set Vertex
xs, Set Vertex -> [Vertex]
forall a. Set a -> [a]
Set.toList Set Vertex
ys)
splitByReachability :: Ord a => AdjacencyMap a -> [a] -> (Set a, Set a)
splitByReachability :: AdjacencyMap a -> [a] -> (Set a, Set a)
splitByReachability AdjacencyMap a
m [a]
vs = let s :: Set a
s = [a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList ([a] -> AdjacencyMap a -> [a]
forall a. Ord a => [a] -> AdjacencyMap a -> [a]
dfs [a]
vs AdjacencyMap a
m) in (Set a
s, AdjacencyMap a -> Set a
forall a. AdjacencyMap a -> Set a
vertexSet AdjacencyMap a
m Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set a
s)