{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
module HieDb.Query where

import           Algebra.Graph.AdjacencyMap (AdjacencyMap, edges, induce, vertexSet, vertices, overlay, transpose)
import           Algebra.Graph.AdjacencyMap.Algorithm (reachable)
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

{-| List all modules indexed in HieDb. -}
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"

{-| List all module exports -}
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"

{-| List all exports of the given module -}
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)

{-| Find all the modules that export an identifier |-}
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)

{-| Lookup Unit 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 Unit)
resolveUnitId :: HieDb -> ModuleName -> IO (Either HieDbErr Unit)
resolveUnitId (HieDb -> Connection
getConn -> Connection
conn) ModuleName
mn = do
  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)
  return $ case 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
")"

{-| Lookup all 'HieModule' rows from 'HieDb' that are part of a given 'Unit' -}
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)

{-| Lookup 'HieModule' row from 'HieDb' given its 'ModuleName' and 'Unit' -}
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
  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 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)

{-| Lookup 'HieModule' row from 'HieDb' given the path to the Haskell source file -}
lookupHieFileFromSource :: HieDb -> FilePath -> IO (Maybe HieModuleRow)
lookupHieFileFromSource :: HieDb -> String -> IO (Maybe HieModuleRow)
lookupHieFileFromSource (HieDb -> Connection
getConn -> Connection
conn) String
fp = do
  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 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)

{-| Lookup 'HieModule' row from 'HieDb' given the hash of the HIE file -}
lookupHieFileFromHash :: HieDb -> Fingerprint -> IO (Maybe HieModuleRow)
lookupHieFileFromHash :: HieDb -> Fingerprint -> IO (Maybe HieModuleRow)
lookupHieFileFromHash (HieDb -> Connection
getConn -> Connection
conn) Fingerprint
hash = do
  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 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 = (OccName -> Maybe ModuleName -> Maybe Unit -> IO [Res DefRow])
-> OccName
-> Maybe ModuleName
-> Maybe Unit
-> IO (Either HieDbErr (Res DefRow))
forall (f :: * -> *) a.
Functor f =>
(OccName -> Maybe ModuleName -> Maybe Unit -> f [Res a])
-> OccName
-> Maybe ModuleName
-> Maybe Unit
-> f (Either HieDbErr (Res a))
findOneVia ((OccName -> Maybe ModuleName -> Maybe Unit -> IO [Res DefRow])
 -> OccName
 -> Maybe ModuleName
 -> Maybe Unit
 -> IO (Either HieDbErr (Res DefRow)))
-> (HieDb
    -> OccName -> Maybe ModuleName -> Maybe Unit -> IO [Res DefRow])
-> HieDb
-> OccName
-> Maybe ModuleName
-> Maybe Unit
-> IO (Either HieDbErr (Res DefRow))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HieDb
-> OccName -> Maybe ModuleName -> Maybe Unit -> IO [Res DefRow]
findDef

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
"%")

findDecl :: HieDb -> OccName -> Maybe ModuleName -> Maybe Unit -> IO [Res DeclRow]
findDecl :: HieDb
-> OccName -> Maybe ModuleName -> Maybe Unit -> IO [Res DeclRow]
findDecl HieDb
conn OccName
occ Maybe ModuleName
mn Maybe Unit
uid
  = Connection -> Query -> [NamedParam] -> IO [Res DeclRow]
forall r.
FromRow r =>
Connection -> Query -> [NamedParam] -> IO [r]
queryNamed (HieDb -> Connection
getConn HieDb
conn) Query
"SELECT decls.*, mods.mod,mods.unit,mods.is_boot,mods.hs_src,mods.is_real,mods.hash \
                              \FROM decls 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]

findOneDecl :: HieDb -> OccName -> Maybe ModuleName -> Maybe Unit -> IO (Either HieDbErr (Res DeclRow))
findOneDecl :: HieDb
-> OccName
-> Maybe ModuleName
-> Maybe Unit
-> IO (Either HieDbErr (Res DeclRow))
findOneDecl = (OccName -> Maybe ModuleName -> Maybe Unit -> IO [Res DeclRow])
-> OccName
-> Maybe ModuleName
-> Maybe Unit
-> IO (Either HieDbErr (Res DeclRow))
forall (f :: * -> *) a.
Functor f =>
(OccName -> Maybe ModuleName -> Maybe Unit -> f [Res a])
-> OccName
-> Maybe ModuleName
-> Maybe Unit
-> f (Either HieDbErr (Res a))
findOneVia ((OccName -> Maybe ModuleName -> Maybe Unit -> IO [Res DeclRow])
 -> OccName
 -> Maybe ModuleName
 -> Maybe Unit
 -> IO (Either HieDbErr (Res DeclRow)))
-> (HieDb
    -> OccName -> Maybe ModuleName -> Maybe Unit -> IO [Res DeclRow])
-> HieDb
-> OccName
-> Maybe ModuleName
-> Maybe Unit
-> IO (Either HieDbErr (Res DeclRow))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HieDb
-> OccName -> Maybe ModuleName -> Maybe Unit -> IO [Res DeclRow]
findDecl

findOneVia
  :: Functor f
  => (OccName -> Maybe ModuleName -> Maybe Unit -> f [Res a])
  -> OccName
  -> Maybe ModuleName
  -> Maybe Unit
  -> f (Either HieDbErr (Res a))
findOneVia :: forall (f :: * -> *) a.
Functor f =>
(OccName -> Maybe ModuleName -> Maybe Unit -> f [Res a])
-> OccName
-> Maybe ModuleName
-> Maybe Unit
-> f (Either HieDbErr (Res a))
findOneVia OccName -> Maybe ModuleName -> Maybe Unit -> f [Res a]
f OccName
occ Maybe ModuleName
mn Maybe Unit
muid = [Res a] -> Either HieDbErr (Res a)
forall {h}. [h :. ModuleInfo] -> Either HieDbErr (h :. ModuleInfo)
wrap ([Res a] -> Either HieDbErr (Res a))
-> f [Res a] -> f (Either HieDbErr (Res a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OccName -> Maybe ModuleName -> Maybe Unit -> f [Res a]
f 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
declUnit 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
declUnit [h :. ModuleInfo]
xs)
    declUnit :: (h :. t) -> t
declUnit (h
_:.t
i) = t
i

{-| @withTarget db t f@ runs function @f@ with HieFile specified by HieTarget @t@.
In case the target is given by ModuleName (and optionally Unit) it is first resolved
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 :: 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
    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 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
        mModRow <- HieDb -> ModuleName -> Unit -> IO (Maybe HieModuleRow)
lookupHieFile HieDb
conn ModuleName
mn Unit
uid
        case 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
      fp' <- String -> IO String
canonicalizePath String
fp
      nc <- newIORef =<< makeNc
      runDbM nc $ do
        Right <$> withHieFile fp' (return . f)


type Vertex = (String, String, String, Int, Int, Int, Int)

-- | Find a @'Res' 'DeclRow'@ by name and return it as a 'Vertex'
lookupVertex :: HieDb -> OccName -> Maybe ModuleName -> Maybe Unit -> IO (Either HieDbErr Vertex)
lookupVertex :: HieDb
-> OccName
-> Maybe ModuleName
-> Maybe Unit
-> IO (Either HieDbErr Vertex)
lookupVertex HieDb
db OccName
occ Maybe ModuleName
mm Maybe Unit
muid =
  (Res DeclRow -> Vertex)
-> Either HieDbErr (Res DeclRow) -> Either HieDbErr Vertex
forall a b. (a -> b) -> Either HieDbErr a -> Either HieDbErr b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Res DeclRow -> Vertex
declRowToVertex (Either HieDbErr (Res DeclRow) -> Either HieDbErr Vertex)
-> IO (Either HieDbErr (Res DeclRow))
-> IO (Either HieDbErr Vertex)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HieDb
-> OccName
-> Maybe ModuleName
-> Maybe Unit
-> IO (Either HieDbErr (Res DeclRow))
findOneDecl HieDb
db OccName
occ Maybe ModuleName
mm Maybe Unit
muid
 where
  declRowToVertex :: Res DeclRow -> Vertex
  declRowToVertex :: Res DeclRow -> Vertex
declRowToVertex (DeclRow
dr :. ModuleInfo
mi) =
    ( ModuleName -> String
moduleNameString (ModuleName -> String) -> ModuleName -> String
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> ModuleName
modInfoName ModuleInfo
mi
    , DeclRow -> String
declSrc DeclRow
dr
    , OccName -> String
occNameToField (OccName -> String) -> OccName -> String
forall a b. (a -> b) -> a -> b
$ DeclRow -> OccName
declNameOcc DeclRow
dr
    , DeclRow -> Int
declSLine DeclRow
dr
    , DeclRow -> Int
declSCol DeclRow
dr
    , DeclRow -> Int
declELine DeclRow
dr
    , DeclRow -> Int
declECol DeclRow
dr
    )

  occNameToField :: OccName -> String
  occNameToField :: OccName -> String
occNameToField OccName
occ = NameSpace -> String
toNsChar (OccName -> NameSpace
occNameSpace OccName
occ) String -> String -> String
forall a. [a] -> [a] -> [a]
++ OccName -> String
occNameString OccName
occ

declRefs :: HieDb -> Maybe Vertex -> IO ()
declRefs :: HieDb -> Maybe Vertex -> IO ()
declRefs HieDb
db Maybe Vertex
mv = do
  graph <- HieDb -> IO (AdjacencyMap Vertex)
getGraph HieDb
db
  writeFile
    "refs.dot"
    ( export
        ( ( 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"
              ]
          }
        )
        (maybe id pruneToCallersOf mv graph)
    )

pruneToCallersOf :: Vertex -> AdjacencyMap Vertex -> AdjacencyMap Vertex
pruneToCallersOf :: Vertex -> AdjacencyMap Vertex -> AdjacencyMap Vertex
pruneToCallersOf Vertex
v AdjacencyMap Vertex
g = (Vertex -> Bool) -> AdjacencyMap Vertex -> AdjacencyMap Vertex
forall a. (a -> Bool) -> AdjacencyMap a -> AdjacencyMap a
induce (Vertex -> [Vertex] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Vertex]
vs) AdjacencyMap Vertex
g
 where
  vs :: [Vertex]
vs = AdjacencyMap Vertex -> Vertex -> [Vertex]
forall a. Ord a => AdjacencyMap a -> a -> [a]
reachable (AdjacencyMap Vertex -> AdjacencyMap Vertex
forall a. Ord a => AdjacencyMap a -> AdjacencyMap a
transpose AdjacencyMap Vertex
g) Vertex
v

getGraph :: HieDb -> IO (AdjacencyMap Vertex)
getGraph :: HieDb -> IO (AdjacencyMap Vertex)
getGraph (HieDb -> Connection
getConn -> Connection
conn) = do
  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))"
  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 (\( Vertex
x :. Vertex
y ) -> ( Vertex
x, Vertex
y )) 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
    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
    forM_ (Map.toList m) $ \(String
fp, (ModuleName
mod', Set Span
sps)) -> do
        code <- String -> m [Text]
forall (m :: * -> *).
(NameCacheMonad m, MonadIO m) =>
String -> m [Text]
sourceCode String
fp
        let fp' = String -> String -> String
replaceExtension String
fp String
"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 :: HieDb -> [Symbol] -> IO (Map String (ModuleName, Set Span))
getAnnotations HieDb
db [Symbol]
symbols = do
    (rs, us) <- HieDb -> [Symbol] -> IO ([Vertex], [Vertex])
getReachableUnreachable HieDb
db [Symbol]
symbols
    let 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)
 -> 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
    return 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
  vs <- HieDb -> [Symbol] -> IO [Vertex]
getVertices HieDb
db [Symbol]
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 :: 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)