{-# 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.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 a. a -> IO a
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
-> [String]
-> IO [Res RefRow]
findReferences (HieDb -> Connection
getConn -> Connection
conn) Bool
isReal OccName
occ Maybe ModuleName
mn Maybe Unit
uid [String]
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 -> String -> NamedParam) -> [Int] -> [String] -> [NamedParam]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
n String
f -> (Text
":exclude" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
n)) Text -> String -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= String
f) [Int
1 :: Int ..] [String]
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
")"
lookupPackage :: HieDb -> Unit -> IO [HieModuleRow]
lookupPackage :: HieDb -> Unit -> IO [HieModuleRow]
lookupPackage (HieDb -> Connection
getConn -> Connection
conn) Unit
uid =
Connection -> Query -> Only Unit -> IO [HieModuleRow]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query Connection
conn Query
"SELECT * FROM mods WHERE unit = ?" (Unit -> Only Unit
forall a. a -> Only a
Only Unit
uid)
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe HieModuleRow
forall a. Maybe a
Nothing
[HieModuleRow
x] -> Maybe HieModuleRow -> IO (Maybe HieModuleRow)
forall a. a -> IO a
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 ->
String -> IO (Maybe HieModuleRow)
forall a. HasCallStack => String -> a
error (String -> IO (Maybe HieModuleRow))
-> String -> IO (Maybe HieModuleRow)
forall a b. (a -> b) -> a -> b
$ String
"DB invariant violated, (mod,unit) in mods not unique: "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String, Unit) -> String
forall a. Show a => a -> String
show (ModuleName -> String
moduleNameString ModuleName
mn, Unit
uid) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
". Entries: "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((HieModuleRow -> String) -> [HieModuleRow] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map HieModuleRow -> String
hieModuleHieFile [HieModuleRow]
xs)
lookupHieFileFromSource :: HieDb -> FilePath -> IO (Maybe HieModuleRow)
lookupHieFileFromSource :: HieDb -> String -> IO (Maybe HieModuleRow)
lookupHieFileFromSource (HieDb -> Connection
getConn -> Connection
conn) String
fp = do
[HieModuleRow]
files <- Connection -> Query -> Only String -> IO [HieModuleRow]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query Connection
conn Query
"SELECT * FROM mods WHERE hs_src = ?" (String -> Only String
forall a. a -> Only a
Only String
fp)
case [HieModuleRow]
files of
[] -> Maybe HieModuleRow -> IO (Maybe HieModuleRow)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe HieModuleRow
forall a. Maybe a
Nothing
[HieModuleRow
x] -> Maybe HieModuleRow -> IO (Maybe HieModuleRow)
forall a. a -> IO a
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 ->
String -> IO (Maybe HieModuleRow)
forall a. HasCallStack => String -> a
error (String -> IO (Maybe HieModuleRow))
-> String -> IO (Maybe HieModuleRow)
forall a b. (a -> b) -> a -> b
$ String
"DB invariant violated, hs_src in mods not unique: "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
fp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
". Entries: "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((HieModuleRow -> String) -> [HieModuleRow] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ([SQLData] -> String
forall a. Show a => a -> String
show ([SQLData] -> String)
-> (HieModuleRow -> [SQLData]) -> HieModuleRow -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HieModuleRow -> [SQLData]
forall a. ToRow a => a -> [SQLData]
toRow) [HieModuleRow]
xs)
lookupHieFileFromHash :: HieDb -> Fingerprint -> IO (Maybe HieModuleRow)
lookupHieFileFromHash :: HieDb -> Fingerprint -> IO (Maybe HieModuleRow)
lookupHieFileFromHash (HieDb -> Connection
getConn -> Connection
conn) Fingerprint
hash = do
[HieModuleRow]
files <- Connection -> Query -> Only Fingerprint -> IO [HieModuleRow]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query Connection
conn Query
"SELECT * FROM mods WHERE hash = ?" (Fingerprint -> Only Fingerprint
forall a. a -> Only a
Only Fingerprint
hash)
case [HieModuleRow]
files of
[] -> Maybe HieModuleRow -> IO (Maybe HieModuleRow)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe HieModuleRow
forall a. Maybe a
Nothing
[HieModuleRow
x] -> Maybe HieModuleRow -> IO (Maybe HieModuleRow)
forall a. a -> IO a
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 ->
String -> IO (Maybe HieModuleRow)
forall a. HasCallStack => String -> a
error (String -> IO (Maybe HieModuleRow))
-> String -> IO (Maybe HieModuleRow)
forall a b. (a -> b) -> a -> b
$ String
"DB invariant violated, hash in mods not unique: "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Fingerprint -> String
forall a. Show a => a -> String
show Fingerprint
hash String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
". Entries: "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((HieModuleRow -> String) -> [HieModuleRow] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ([SQLData] -> String
forall a. Show a => a -> String
show ([SQLData] -> String)
-> (HieModuleRow -> [SQLData]) -> HieModuleRow -> String
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
-> [String]
-> IO [Res TypeRef]
findTypeRefs (HieDb -> Connection
getConn -> Connection
conn) Bool
isReal OccName
occ Maybe ModuleName
mn Maybe Unit
uid [String]
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 -> String -> NamedParam) -> [Int] -> [String] -> [NamedParam]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
n String
f -> (Text
":exclude" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
n)) Text -> String -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= String
f) [Int
1 :: Int ..] [String]
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 -> String -> IO [Res DefRow]
searchDef HieDb
conn String
cs
= Connection -> Query -> Only String -> 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" (String -> Only String
forall a. a -> Only a
Only (String -> Only String) -> String -> Only String
forall a b. (a -> b) -> a -> b
$ Char
'_'Char -> String -> String
forall a. a -> [a] -> [a]
:Char
':'Char -> String -> String
forall a. a -> [a] -> [a]
:String
csString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"%")
withTarget
:: HieDb
-> HieTarget
-> (HieFile -> a)
-> IO (Either HieDbErr a)
withTarget :: forall a.
HieDb -> HieTarget -> (HieFile -> a) -> IO (Either HieDbErr a)
withTarget HieDb
conn HieTarget
target HieFile -> a
f = case HieTarget
target of
Left String
fp -> String -> IO (Either HieDbErr a)
forall {a}. String -> IO (Either a a)
processHieFile String
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 a. a -> IO a
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 a. a -> IO 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 a. a -> IO 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 -> String -> IO (Either HieDbErr a)
forall {a}. String -> IO (Either a a)
processHieFile (HieModuleRow -> String
hieModuleHieFile HieModuleRow
modRow)
where
processHieFile :: String -> IO (Either a a)
processHieFile String
fp = do
String
fp' <- String -> IO String
canonicalizePath String
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
<$> String -> (HieFile -> DbMonadT IO a) -> DbMonadT IO a
forall (m :: * -> *) a.
(NameCacheMonad m, MonadIO m) =>
String -> (HieFile -> m a) -> m a
withHieFile String
fp' (a -> DbMonadT IO a
forall a. 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
String -> String -> IO ()
writeFile
String
"refs.dot"
( Style Vertex String -> AdjacencyMap Vertex -> String
forall s a g.
(IsString s, Monoid s, Ord a, ToGraph g, ToVertex g ~ a) =>
Style a s -> g -> s
export
( ( (Vertex -> String) -> Style Vertex String
forall s a. Monoid s => (a -> s) -> Style a s
defaultStyle ( \( String
_, String
hie, String
occ, Int
_, Int
_, Int
_, Int
_ ) -> String
hie String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
":" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
occ ) )
{ vertexAttributes = \( String
mod', String
_, String
occ, Int
_, Int
_, Int
_, Int
_ ) ->
[ String
"label" String -> String -> Attribute String
forall s. s -> s -> Attribute s
G.:= ( String
mod' String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 String
occ )
, String
"fillcolor" String -> String -> Attribute String
forall s. s -> s -> Attribute s
G.:= case String
occ of (Char
'v':String
_) -> String
"red"; (Char
't':String
_) -> String
"blue";String
_ -> String
"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 a. a -> IO a
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 b a. (b -> a -> b) -> b -> [a] -> b
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 :: OccName
n = Symbol -> OccName
symName Symbol
s
m :: String
m = ModuleName -> String
moduleNameString (ModuleName -> String) -> ModuleName -> String
forall a b. (a -> b) -> a -> b
$ GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (GenModule Unit -> ModuleName) -> GenModule Unit -> ModuleName
forall a b. (a -> b) -> a -> b
$ Symbol -> GenModule Unit
symModule Symbol
s
u :: String
u = Unit -> String
forall u. IsUnitId u => u -> String
unitString (GenModule Unit -> Unit
forall unit. GenModule unit -> unit
moduleUnit (GenModule Unit -> Unit) -> GenModule Unit -> Unit
forall a b. (a -> b) -> a -> b
$ Symbol -> GenModule Unit
symModule Symbol
s)
Connection -> Query -> (OccName, String, String) -> 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 = ? ) " (OccName
n, String
m, String
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 :: forall (m :: * -> *).
(NameCacheMonad m, MonadIO m) =>
HieDb -> [Symbol] -> m ()
html HieDb
db [Symbol]
symbols = do
Map String (ModuleName, Set Span)
m <- IO (Map String (ModuleName, Set Span))
-> m (Map String (ModuleName, Set Span))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map String (ModuleName, Set Span))
-> m (Map String (ModuleName, Set Span)))
-> IO (Map String (ModuleName, Set Span))
-> m (Map String (ModuleName, Set Span))
forall a b. (a -> b) -> a -> b
$ HieDb -> [Symbol] -> IO (Map String (ModuleName, Set Span))
getAnnotations HieDb
db [Symbol]
symbols
[(String, (ModuleName, Set Span))]
-> ((String, (ModuleName, Set Span)) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map String (ModuleName, Set Span)
-> [(String, (ModuleName, Set Span))]
forall k a. Map k a -> [(k, a)]
Map.toList Map String (ModuleName, Set Span)
m) (((String, (ModuleName, Set Span)) -> m ()) -> m ())
-> ((String, (ModuleName, Set Span)) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(String
fp, (ModuleName
mod', Set Span
sps)) -> do
[Text]
code <- String -> m [Text]
forall (m :: * -> *).
(NameCacheMonad m, MonadIO m) =>
String -> m [Text]
sourceCode String
fp
let fp' :: String
fp' = String -> String -> String
replaceExtension String
fp String
"html"
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ ModuleName -> String
moduleNameString ModuleName
mod' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fp'
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> ModuleName -> [Text] -> [Span] -> IO ()
Html.generate String
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 String (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 String (ModuleName, Set Span)
m1 = (Map String (ModuleName, Set Span)
-> Vertex -> Map String (ModuleName, Set Span))
-> Map String (ModuleName, Set Span)
-> [Vertex]
-> Map String (ModuleName, Set Span)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Color
-> Map String (ModuleName, Set Span)
-> Vertex
-> Map String (ModuleName, Set Span)
f Color
Html.Reachable) Map String (ModuleName, Set Span)
forall k a. Map k a
Map.empty [Vertex]
rs
m2 :: Map String (ModuleName, Set Span)
m2 = (Map String (ModuleName, Set Span)
-> Vertex -> Map String (ModuleName, Set Span))
-> Map String (ModuleName, Set Span)
-> [Vertex]
-> Map String (ModuleName, Set Span)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Color
-> Map String (ModuleName, Set Span)
-> Vertex
-> Map String (ModuleName, Set Span)
f Color
Html.Unreachable) Map String (ModuleName, Set Span)
m1 [Vertex]
us
Map String (ModuleName, Set Span)
-> IO (Map String (ModuleName, Set Span))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Map String (ModuleName, Set Span)
m2
where
f :: Html.Color
-> Map FilePath (ModuleName, Set Html.Span)
-> Vertex
-> Map FilePath (ModuleName, Set Html.Span)
f :: Color
-> Map String (ModuleName, Set Span)
-> Vertex
-> Map String (ModuleName, Set Span)
f Color
c Map String (ModuleName, Set Span)
m Vertex
v =
let (String
fp, ModuleName
mod', Span
sp) = Color -> Vertex -> (String, ModuleName, Span)
g Color
c Vertex
v
in ((ModuleName, Set Span)
-> (ModuleName, Set Span) -> (ModuleName, Set Span))
-> String
-> (ModuleName, Set Span)
-> Map String (ModuleName, Set Span)
-> Map String (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 String
fp (ModuleName
mod', Span -> Set Span
forall a. a -> Set a
Set.singleton Span
sp) Map String (ModuleName, Set Span)
m
g :: Html.Color -> Vertex -> (FilePath, ModuleName, Html.Span)
g :: Color -> Vertex -> (String, ModuleName, Span)
g Color
c (String
mod', String
fp, String
_, Int
sl, Int
sc, Int
el, Int
ec) = (String
fp, String -> ModuleName
mkModuleName String
mod', 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 a. a -> IO a
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 :: forall a. Ord a => 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 (AdjacencyMap a -> [a] -> [a]
forall a. Ord a => AdjacencyMap a -> [a] -> [a]
dfs AdjacencyMap a
m [a]
vs) 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)