{-# 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) = 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) = 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 =
  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 = ?" (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 =
  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 <- 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" (forall a. a -> Only a
Only ModuleName
mn)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case [ModuleInfo]
luid of
    [] ->  forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ ModuleName -> Maybe Unit -> HieDbErr
NotIndexed ModuleName
mn forall a. Maybe a
Nothing
    [ModuleInfo
x] -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ ModuleInfo -> Unit
modInfoUnit ModuleInfo
x
    (ModuleInfo
x:[ModuleInfo]
xs) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ NonEmpty ModuleInfo -> HieDbErr
AmbiguousUnitId forall a b. (a -> b) -> a -> b
$ ModuleInfo
x 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
-> [[Char]]
-> IO [Res RefRow]
findReferences (HieDb -> Connection
getConn -> Connection
conn) Bool
isReal OccName
occ Maybe ModuleName
mn Maybe Unit
uid [[Char]]
exclude =
  forall r.
FromRow r =>
Connection -> Query -> [NamedParam] -> IO [r]
queryNamed Connection
conn Query
thisQuery ([Text
":occ" forall v. ToField v => Text -> v -> NamedParam
:= OccName
occ, Text
":mod" forall v. ToField v => Text -> v -> NamedParam
:= Maybe ModuleName
mn, Text
":unit" forall v. ToField v => Text -> v -> NamedParam
:= Maybe Unit
uid, Text
":real" forall v. ToField v => Text -> v -> NamedParam
:= Bool
isReal] forall a. [a] -> [a] -> [a]
++ [NamedParam]
excludedFields)
  where
    excludedFields :: [NamedParam]
excludedFields = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
n [Char]
f -> (Text
":exclude" forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (forall a. Show a => a -> [Char]
show Int
n)) forall v. ToField v => Text -> v -> NamedParam
:= [Char]
f) [Int
1 :: Int ..] [[Char]]
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))"
      forall a. Semigroup a => a -> a -> a
<> Query
" AND mods.hs_src NOT IN (" forall a. Semigroup a => a -> a -> a
<> Text -> Query
Query (Text -> [Text] -> Text
T.intercalate Text
"," (forall a b. (a -> b) -> [a] -> [b]
map (\(Text
l := v
_) -> Text
l) [NamedParam]
excludedFields)) 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 =
  forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query Connection
conn Query
"SELECT * FROM mods WHERE 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 <- 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
    [] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    [HieModuleRow
x] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just HieModuleRow
x
    [HieModuleRow]
xs ->
      forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"DB invariant violated, (mod,unit) in mods not unique: "
            forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (ModuleName -> [Char]
moduleNameString ModuleName
mn, Unit
uid) forall a. [a] -> [a] -> [a]
++ [Char]
". Entries: "
            forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " (forall a b. (a -> b) -> [a] -> [b]
map HieModuleRow -> [Char]
hieModuleHieFile [HieModuleRow]
xs)

{-| Lookup 'HieModule' row from 'HieDb' given the path to the Haskell source file -}
lookupHieFileFromSource :: HieDb -> FilePath -> IO (Maybe HieModuleRow)
lookupHieFileFromSource :: HieDb -> [Char] -> IO (Maybe HieModuleRow)
lookupHieFileFromSource (HieDb -> Connection
getConn -> Connection
conn) [Char]
fp = do
  [HieModuleRow]
files <- forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query Connection
conn Query
"SELECT * FROM mods WHERE hs_src = ?" (forall a. a -> Only a
Only [Char]
fp)
  case [HieModuleRow]
files of
    [] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    [HieModuleRow
x] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just HieModuleRow
x
    [HieModuleRow]
xs ->
      forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"DB invariant violated, hs_src in mods not unique: "
            forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
fp forall a. [a] -> [a] -> [a]
++ [Char]
". Entries: "
            forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Show a => a -> [Char]
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 <- forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query Connection
conn Query
"SELECT * FROM mods WHERE hash = ?" (forall a. a -> Only a
Only Fingerprint
hash)
  case [HieModuleRow]
files of
    [] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    [HieModuleRow
x] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just HieModuleRow
x
    [HieModuleRow]
xs ->
      forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"DB invariant violated, hash in mods not unique: "
            forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Fingerprint
hash forall a. [a] -> [a] -> [a]
++ [Char]
". Entries: "
            forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Show a => a -> [Char]
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
-> [[Char]]
-> IO [Res TypeRef]
findTypeRefs (HieDb -> Connection
getConn -> Connection
conn) Bool
isReal OccName
occ Maybe ModuleName
mn Maybe Unit
uid [[Char]]
exclude
  = forall r.
FromRow r =>
Connection -> Query -> [NamedParam] -> IO [r]
queryNamed Connection
conn Query
thisQuery ([Text
":occ" forall v. ToField v => Text -> v -> NamedParam
:= OccName
occ, Text
":mod" forall v. ToField v => Text -> v -> NamedParam
:= Maybe ModuleName
mn, Text
":unit" forall v. ToField v => Text -> v -> NamedParam
:= Maybe Unit
uid, Text
":real" forall v. ToField v => Text -> v -> NamedParam
:= Bool
isReal] forall a. [a] -> [a] -> [a]
++ [NamedParam]
excludedFields)
  where
    excludedFields :: [NamedParam]
excludedFields = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
n [Char]
f -> (Text
":exclude" forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (forall a. Show a => a -> [Char]
show Int
n)) forall v. ToField v => Text -> v -> NamedParam
:= [Char]
f) [Int
1 :: Int ..] [[Char]]
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))"
      forall a. Semigroup a => a -> a -> a
<> Query
" AND mods.hs_src NOT IN (" forall a. Semigroup a => a -> a -> a
<> Text -> Query
Query (Text -> [Text] -> Text
T.intercalate Text
"," (forall a b. (a -> b) -> [a] -> [b]
map (\(Text
l := v
_) -> Text
l) [NamedParam]
excludedFields)) forall a. Semigroup a => a -> a -> a
<> 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
  = 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" forall v. ToField v => Text -> v -> NamedParam
:= OccName
occ,Text
":mod" forall v. ToField v => Text -> v -> NamedParam
:= Maybe ModuleName
mn, Text
":unit" 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 = forall {h}. [h :. ModuleInfo] -> Either HieDbErr (h :. ModuleInfo)
wrap 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]    = forall a b. b -> Either a b
Right h :. ModuleInfo
x
    wrap []     = forall a b. a -> Either a b
Left 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) = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ NonEmpty ModuleInfo -> HieDbErr
AmbiguousUnitId (forall {h} {t}. (h :. t) -> t
defUnit h :. ModuleInfo
x forall a. a -> [a] -> NonEmpty a
:| forall a b. (a -> b) -> [a] -> [b]
map 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 -> [Char] -> IO [Res DefRow]
searchDef HieDb
conn [Char]
cs
  = 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" (forall a. a -> Only a
Only forall a b. (a -> b) -> a -> b
$ Char
'_'forall a. a -> [a] -> [a]
:[Char]
csforall a. [a] -> [a] -> [a]
++[Char]
"%")

{-| @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 [Char]
fp -> forall {a}. [Char] -> IO (Either a a)
processHieFile [Char]
fp
  Right (ModuleName
mn,Maybe Unit
muid) -> do
    Either HieDbErr Unit
euid <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (HieDb -> ModuleName -> IO (Either HieDbErr Unit)
resolveUnitId HieDb
conn ModuleName
mn) (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right) Maybe Unit
muid
    case Either HieDbErr Unit
euid of
      Left HieDbErr
err -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (ModuleName -> Maybe Unit -> HieDbErr
NotIndexed ModuleName
mn forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Unit
uid)
          Just HieModuleRow
modRow -> forall {a}. [Char] -> IO (Either a a)
processHieFile (HieModuleRow -> [Char]
hieModuleHieFile HieModuleRow
modRow)
  where
    processHieFile :: [Char] -> IO (Either a a)
processHieFile [Char]
fp = do
      [Char]
fp' <- [Char] -> IO [Char]
canonicalizePath [Char]
fp
      IORef NameCache
nc <- forall a. a -> IO (IORef a)
newIORef forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO NameCache
makeNc
      forall a. IORef NameCache -> DbMonad a -> IO a
runDbM IORef NameCache
nc forall a b. (a -> b) -> a -> b
$ do
        forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
(NameCacheMonad m, MonadIO m) =>
[Char] -> (HieFile -> m a) -> m a
withHieFile [Char]
fp' (forall (m :: * -> *) a. Monad m => a -> m a
return 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
  [Char] -> [Char] -> IO ()
writeFile
    [Char]
"refs.dot"
    ( forall s a g.
(IsString s, Monoid s, Ord a, ToGraph g, ToVertex g ~ a) =>
Style a s -> g -> s
export
        ( ( forall s a. Monoid s => (a -> s) -> Style a s
defaultStyle ( \( [Char]
_, [Char]
hie, [Char]
occ, Int
_, Int
_, Int
_, Int
_ ) -> [Char]
hie forall a. Semigroup a => a -> a -> a
<> [Char]
":" forall a. Semigroup a => a -> a -> a
<> [Char]
occ ) )
          { vertexAttributes :: Vertex -> [Attribute [Char]]
vertexAttributes = \( [Char]
mod', [Char]
_, [Char]
occ, Int
_, Int
_, Int
_, Int
_ ) ->
              [ [Char]
"label" forall s. s -> s -> Attribute s
G.:= ( [Char]
mod' forall a. Semigroup a => a -> a -> a
<> [Char]
"." forall a. Semigroup a => a -> a -> a
<> forall a. Int -> [a] -> [a]
drop Int
1 [Char]
occ )
              , [Char]
"fillcolor" forall s. s -> s -> Attribute s
G.:= case [Char]
occ of (Char
'v':[Char]
_) -> [Char]
"red"; (Char
't':[Char]
_) -> [Char]
"blue";[Char]
_ -> [Char]
"black"
              ]
          }
        )
        AdjacencyMap Vertex
graph
    )

getGraph :: HieDb -> IO (AdjacencyMap Vertex)
getGraph :: HieDb -> IO (AdjacencyMap Vertex)
getGraph (HieDb -> Connection
getConn -> Connection
conn) = do
  [Vertex :. Vertex]
es <-
    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 <-
    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)"
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a.
Ord a =>
AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a
overlay ( forall a. Ord a => [a] -> AdjacencyMap a
vertices [Vertex]
vs ) ( forall a. Ord a => [(a, a)] -> AdjacencyMap a
edges ( 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 = forall a. Set a -> [a]
Set.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 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 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Ord a => a -> Set a -> Set a
Set.insert) Set Vertex
vs 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 :: [Char]
n = NameSpace -> Char
toNsChar (OccName -> NameSpace
occNameSpace forall a b. (a -> b) -> a -> b
$ Symbol -> OccName
symName Symbol
s) forall a. a -> [a] -> [a]
: OccName -> [Char]
occNameString (Symbol -> OccName
symName Symbol
s)
          m :: [Char]
m = ModuleName -> [Char]
moduleNameString forall a b. (a -> b) -> a -> b
$ forall unit. GenModule unit -> ModuleName
moduleName forall a b. (a -> b) -> a -> b
$ Symbol -> Module
symModule Symbol
s
          u :: [Char]
u = forall u. IsUnitId u => u -> [Char]
unitString (forall unit. GenModule unit -> unit
moduleUnit forall a b. (a -> b) -> a -> b
$ Symbol -> Module
symModule Symbol
s)
      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 = ? ) " ([Char]
n, [Char]
m, [Char]
u)

getReachable :: HieDb -> [Symbol] -> IO [Vertex]
getReachable :: HieDb -> [Symbol] -> IO [Vertex]
getReachable HieDb
db [Symbol]
symbols = forall a b. (a, b) -> a
fst 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 = forall a b. (a, b) -> b
snd 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 [Char] (ModuleName, Set Span)
m <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HieDb -> [Symbol] -> IO (Map [Char] (ModuleName, Set Span))
getAnnotations HieDb
db [Symbol]
symbols
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall k a. Map k a -> [(k, a)]
Map.toList Map [Char] (ModuleName, Set Span)
m) forall a b. (a -> b) -> a -> b
$ \([Char]
fp, (ModuleName
mod', Set Span
sps)) -> do
        [Text]
code <- forall (m :: * -> *).
(NameCacheMonad m, MonadIO m) =>
[Char] -> m [Text]
sourceCode [Char]
fp
        let fp' :: [Char]
fp' = [Char] -> [Char] -> [Char]
replaceExtension [Char]
fp [Char]
"html"
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ ModuleName -> [Char]
moduleNameString ModuleName
mod' forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ [Char]
fp'
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> ModuleName -> [Text] -> [Span] -> IO ()
Html.generate [Char]
fp' ModuleName
mod' [Text]
code forall a b. (a -> b) -> a -> b
$ 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 [Char] (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 [Char] (ModuleName, Set Span)
m1 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Color
-> Map [Char] (ModuleName, Set Span)
-> Vertex
-> Map [Char] (ModuleName, Set Span)
f Color
Html.Reachable)   forall k a. Map k a
Map.empty [Vertex]
rs
        m2 :: Map [Char] (ModuleName, Set Span)
m2 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Color
-> Map [Char] (ModuleName, Set Span)
-> Vertex
-> Map [Char] (ModuleName, Set Span)
f Color
Html.Unreachable) Map [Char] (ModuleName, Set Span)
m1        [Vertex]
us
    forall (m :: * -> *) a. Monad m => a -> m a
return Map [Char] (ModuleName, Set Span)
m2
  where
    f :: Html.Color
      -> Map FilePath (ModuleName, Set Html.Span)
      -> Vertex
      -> Map FilePath (ModuleName, Set Html.Span)
    f :: Color
-> Map [Char] (ModuleName, Set Span)
-> Vertex
-> Map [Char] (ModuleName, Set Span)
f Color
c Map [Char] (ModuleName, Set Span)
m Vertex
v =
        let ([Char]
fp, ModuleName
mod', Span
sp) = Color -> Vertex -> ([Char], ModuleName, Span)
g Color
c Vertex
v
        in  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 [Char]
fp (ModuleName
mod', forall a. a -> Set a
Set.singleton Span
sp) Map [Char] (ModuleName, Set Span)
m

    g :: Html.Color -> Vertex -> (FilePath, ModuleName, Html.Span)
    g :: Color -> Vertex -> ([Char], ModuleName, Span)
g Color
c ([Char]
mod', [Char]
fp, [Char]
_, Int
sl, Int
sc, Int
el, Int
ec) = ([Char]
fp, [Char] -> ModuleName
mkModuleName [Char]
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 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) = forall a. Ord a => AdjacencyMap a -> [a] -> (Set a, Set a)
splitByReachability AdjacencyMap Vertex
graph [Vertex]
vs
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Set a -> [a]
Set.toList Set Vertex
xs, 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 = forall a. Ord a => [a] -> Set a
Set.fromList (forall a. Ord a => AdjacencyMap a -> [a] -> [a]
dfs AdjacencyMap a
m [a]
vs) in (Set a
s, forall a. AdjacencyMap a -> Set a
vertexSet AdjacencyMap a
m forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set a
s)