{-# 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

{-| 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
  [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
")"

{-| 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
  [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)

{-| 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
  [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)

{-| 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
  [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 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
    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)