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

import           Algebra.Graph.AdjacencyMap (AdjacencyMap, edges, vertexSet, vertices, overlay)
import           Algebra.Graph.AdjacencyMap.Algorithm (dfs)
import           Algebra.Graph.Export.Dot hiding ((:=))
import qualified Algebra.Graph.Export.Dot as G

import           GHC
import           Compat.HieTypes
import           Module
import           Name

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.Types
import           HieDb.Utils
import           HieDb.Create
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"

{-| Lookup UnitId 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 UnitId)
resolveUnitId :: HieDb -> ModuleName -> IO (Either HieDbErr UnitId)
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, time FROM mods WHERE mod = ? and is_boot = 0" (ModuleName -> Only ModuleName
forall a. a -> Only a
Only ModuleName
mn)
  Either HieDbErr UnitId -> IO (Either HieDbErr UnitId)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either HieDbErr UnitId -> IO (Either HieDbErr UnitId))
-> Either HieDbErr UnitId -> IO (Either HieDbErr UnitId)
forall a b. (a -> b) -> a -> b
$ case [ModuleInfo]
luid of
    [] ->  HieDbErr -> Either HieDbErr UnitId
forall a b. a -> Either a b
Left (HieDbErr -> Either HieDbErr UnitId)
-> HieDbErr -> Either HieDbErr UnitId
forall a b. (a -> b) -> a -> b
$ ModuleName -> Maybe UnitId -> HieDbErr
NotIndexed ModuleName
mn Maybe UnitId
forall a. Maybe a
Nothing
    [ModuleInfo
x] -> UnitId -> Either HieDbErr UnitId
forall a b. b -> Either a b
Right (UnitId -> Either HieDbErr UnitId)
-> UnitId -> Either HieDbErr UnitId
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> UnitId
modInfoUnit ModuleInfo
x
    (ModuleInfo
x:[ModuleInfo]
xs) -> HieDbErr -> Either HieDbErr UnitId
forall a b. a -> Either a b
Left (HieDbErr -> Either HieDbErr UnitId)
-> HieDbErr -> Either HieDbErr UnitId
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

search :: HieDb -> Bool -> OccName -> Maybe ModuleName -> Maybe UnitId -> [FilePath] -> IO [Res RefRow]
search :: HieDb
-> Bool
-> OccName
-> Maybe ModuleName
-> Maybe UnitId
-> [FilePath]
-> IO [Res RefRow]
search (HieDb -> Connection
getConn -> Connection
conn) Bool
isReal OccName
occ Maybe ModuleName
mn Maybe UnitId
uid [FilePath]
exclude =
  Connection -> Query -> [NamedParam] -> IO [Res RefRow]
forall r.
FromRow r =>
Connection -> Query -> [NamedParam] -> IO [r]
queryNamed Connection
conn Query
thisQuery ([Text
":occ" Text -> OccName -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= OccName
occ, Text
":mod" Text -> Maybe ModuleName -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= Maybe ModuleName
mn, Text
":unit" Text -> Maybe UnitId -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= Maybe UnitId
uid, Text
":real" Text -> Bool -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= Bool
isReal] [NamedParam] -> [NamedParam] -> [NamedParam]
forall a. [a] -> [a] -> [a]
++ [NamedParam]
excludedFields)
  where
    excludedFields :: [NamedParam]
excludedFields = (Int -> FilePath -> NamedParam)
-> [Int] -> [FilePath] -> [NamedParam]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
n FilePath
f -> (Text
":exclude" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show Int
n)) Text -> FilePath -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= FilePath
f) [Int
1 :: Int ..] [FilePath]
exclude
    thisQuery :: Query
thisQuery =
      Query
"SELECT refs.*,mods.mod,mods.unit,mods.is_boot,mods.hs_src,mods.is_real,mods.time \
      \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 'HieModule' row from 'HieDb' given its 'ModuleName' and 'UnitId' -}
lookupHieFile :: HieDb -> ModuleName -> UnitId -> IO (Maybe HieModuleRow)
lookupHieFile :: HieDb -> ModuleName -> UnitId -> IO (Maybe HieModuleRow)
lookupHieFile (HieDb -> Connection
getConn -> Connection
conn) ModuleName
mn UnitId
uid = do
  [HieModuleRow]
files <- Connection -> Query -> (ModuleName, UnitId) -> 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, UnitId
uid)
  case [HieModuleRow]
files of
    [] -> Maybe HieModuleRow -> IO (Maybe HieModuleRow)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe HieModuleRow
forall a. Maybe a
Nothing
    [HieModuleRow
x] -> Maybe HieModuleRow -> IO (Maybe HieModuleRow)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe HieModuleRow -> IO (Maybe HieModuleRow))
-> Maybe HieModuleRow -> IO (Maybe HieModuleRow)
forall a b. (a -> b) -> a -> b
$ HieModuleRow -> Maybe HieModuleRow
forall a. a -> Maybe a
Just HieModuleRow
x
    [HieModuleRow]
xs ->
      FilePath -> IO (Maybe HieModuleRow)
forall a. HasCallStack => FilePath -> a
error (FilePath -> IO (Maybe HieModuleRow))
-> FilePath -> IO (Maybe HieModuleRow)
forall a b. (a -> b) -> a -> b
$ FilePath
"DB invariant violated, (mod,unit) in mods not unique: "
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (FilePath, UnitId) -> FilePath
forall a. Show a => a -> FilePath
show (ModuleName -> FilePath
moduleNameString ModuleName
mn, UnitId
uid) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
". Entries: "
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", " ((HieModuleRow -> FilePath) -> [HieModuleRow] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map HieModuleRow -> FilePath
hieModuleHieFile [HieModuleRow]
xs)

{-| Lookup 'HieModule' row from 'HieDb' given the path to the Haskell source file -}
lookupHieFileFromSource :: HieDb -> FilePath -> IO (Maybe HieModuleRow)
lookupHieFileFromSource :: HieDb -> FilePath -> IO (Maybe HieModuleRow)
lookupHieFileFromSource (HieDb -> Connection
getConn -> Connection
conn) FilePath
fp = do
  [HieModuleRow]
files <- Connection -> Query -> Only FilePath -> IO [HieModuleRow]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query Connection
conn Query
"SELECT * FROM mods WHERE hs_src = ?" (FilePath -> Only FilePath
forall a. a -> Only a
Only FilePath
fp)
  case [HieModuleRow]
files of
    [] -> Maybe HieModuleRow -> IO (Maybe HieModuleRow)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe HieModuleRow
forall a. Maybe a
Nothing
    [HieModuleRow
x] -> Maybe HieModuleRow -> IO (Maybe HieModuleRow)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe HieModuleRow -> IO (Maybe HieModuleRow))
-> Maybe HieModuleRow -> IO (Maybe HieModuleRow)
forall a b. (a -> b) -> a -> b
$ HieModuleRow -> Maybe HieModuleRow
forall a. a -> Maybe a
Just HieModuleRow
x
    [HieModuleRow]
xs ->
      FilePath -> IO (Maybe HieModuleRow)
forall a. HasCallStack => FilePath -> a
error (FilePath -> IO (Maybe HieModuleRow))
-> FilePath -> IO (Maybe HieModuleRow)
forall a b. (a -> b) -> a -> b
$ FilePath
"DB invariant violated, hs_src in mods not unique: "
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
fp FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
". Entries: "
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", " ((HieModuleRow -> FilePath) -> [HieModuleRow] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map ([SQLData] -> FilePath
forall a. Show a => a -> FilePath
show ([SQLData] -> FilePath)
-> (HieModuleRow -> [SQLData]) -> HieModuleRow -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HieModuleRow -> [SQLData]
forall a. ToRow a => a -> [SQLData]
toRow) [HieModuleRow]
xs)

findTypeRefs :: HieDb -> OccName -> ModuleName -> UnitId -> IO [Res TypeRef]
findTypeRefs :: HieDb -> OccName -> ModuleName -> UnitId -> IO [Res TypeRef]
findTypeRefs (HieDb -> Connection
getConn -> Connection
conn) OccName
occ ModuleName
mn UnitId
uid
  = Connection
-> Query -> (OccName, ModuleName, UnitId) -> IO [Res TypeRef]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query Connection
conn  Query
"SELECT typerefs.*, mods.mod,mods.unit,mods.is_boot,mods.hs_src,mods.is_real,mods.time \
                \FROM typerefs JOIN mods ON typerefs.hieFile = mods.hieFile \
                              \JOIN typenames ON typerefs.id = typenames.id \
                \WHERE typenames.name = ? AND typenames.mod = ? AND typenames.unit = ? AND mods.is_real \
                       \ORDER BY typerefs.depth ASC"
                (OccName
occ,ModuleName
mn,UnitId
uid)

findDef :: HieDb -> OccName -> Maybe ModuleName -> Maybe UnitId -> IO [Res DefRow]
findDef :: HieDb
-> OccName -> Maybe ModuleName -> Maybe UnitId -> IO [Res DefRow]
findDef HieDb
conn OccName
occ Maybe ModuleName
mn Maybe UnitId
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.time \
                              \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 UnitId -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= Maybe UnitId
uid]

findOneDef :: HieDb -> OccName -> Maybe ModuleName -> Maybe UnitId -> IO (Either HieDbErr (Res DefRow))
findOneDef :: HieDb
-> OccName
-> Maybe ModuleName
-> Maybe UnitId
-> IO (Either HieDbErr (Res DefRow))
findOneDef HieDb
conn OccName
occ Maybe ModuleName
mn Maybe UnitId
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 UnitId -> IO [Res DefRow]
findDef HieDb
conn OccName
occ Maybe ModuleName
mn Maybe UnitId
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 UnitId -> HieDbErr
NameNotFound OccName
occ Maybe ModuleName
mn Maybe UnitId
muid
    wrap (h :. ModuleInfo
x:[h :. ModuleInfo]
xs) = HieDbErr -> Either HieDbErr (h :. ModuleInfo)
forall a b. a -> Either a b
Left (HieDbErr -> Either HieDbErr (h :. ModuleInfo))
-> HieDbErr -> Either HieDbErr (h :. ModuleInfo)
forall a b. (a -> b) -> a -> b
$ NonEmpty ModuleInfo -> HieDbErr
AmbiguousUnitId ((h :. ModuleInfo) -> ModuleInfo
forall h t. (h :. t) -> t
defUnit h :. ModuleInfo
x ModuleInfo -> [ModuleInfo] -> NonEmpty ModuleInfo
forall a. a -> [a] -> NonEmpty a
:| ((h :. ModuleInfo) -> ModuleInfo)
-> [h :. ModuleInfo] -> [ModuleInfo]
forall a b. (a -> b) -> [a] -> [b]
map (h :. ModuleInfo) -> ModuleInfo
forall h t. (h :. t) -> t
defUnit [h :. ModuleInfo]
xs)
    defUnit :: (h :. t) -> t
defUnit (h
_:.t
i) = t
i

searchDef :: HieDb -> String -> IO [Res DefRow]
searchDef :: HieDb -> FilePath -> IO [Res DefRow]
searchDef HieDb
conn FilePath
cs
  = Connection -> Query -> Only FilePath -> IO [Res DefRow]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query (HieDb -> Connection
getConn HieDb
conn) Query
"SELECT defs.*,mods.mod,mods.unit,mods.is_boot,mods.hs_src,mods.is_real,mods.time \
                         \FROM defs JOIN mods USING (hieFile) \
                         \WHERE occ LIKE ? \
                         \LIMIT 200" (FilePath -> Only FilePath
forall a. a -> Only a
Only (FilePath -> Only FilePath) -> FilePath -> Only FilePath
forall a b. (a -> b) -> a -> b
$ Char
'_'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath
csFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
"%")

{-| @withTarget db t f@ runs function @f@ with HieFile specified by HieTarget @t@.
In case the target is given by ModuleName (and optionally UnitId) 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 :: HieDb -> HieTarget -> (HieFile -> a) -> IO (Either HieDbErr a)
withTarget HieDb
conn HieTarget
target HieFile -> a
f = case HieTarget
target of
  Left FilePath
fp -> FilePath -> IO (Either HieDbErr a)
forall a. FilePath -> IO (Either a a)
processHieFile FilePath
fp
  Right (ModuleName
mn,Maybe UnitId
muid) -> do
    Either HieDbErr UnitId
euid <- IO (Either HieDbErr UnitId)
-> (UnitId -> IO (Either HieDbErr UnitId))
-> Maybe UnitId
-> IO (Either HieDbErr UnitId)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (HieDb -> ModuleName -> IO (Either HieDbErr UnitId)
resolveUnitId HieDb
conn ModuleName
mn) (Either HieDbErr UnitId -> IO (Either HieDbErr UnitId)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either HieDbErr UnitId -> IO (Either HieDbErr UnitId))
-> (UnitId -> Either HieDbErr UnitId)
-> UnitId
-> IO (Either HieDbErr UnitId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitId -> Either HieDbErr UnitId
forall a b. b -> Either a b
Right) Maybe UnitId
muid
    case Either HieDbErr UnitId
euid of
      Left HieDbErr
err -> Either HieDbErr a -> IO (Either HieDbErr a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either HieDbErr a -> IO (Either HieDbErr a))
-> Either HieDbErr a -> IO (Either HieDbErr a)
forall a b. (a -> b) -> a -> b
$ HieDbErr -> Either HieDbErr a
forall a b. a -> Either a b
Left HieDbErr
err
      Right UnitId
uid -> do
        Maybe HieModuleRow
mModRow <- HieDb -> ModuleName -> UnitId -> IO (Maybe HieModuleRow)
lookupHieFile HieDb
conn ModuleName
mn UnitId
uid
        case Maybe HieModuleRow
mModRow of
          Maybe HieModuleRow
Nothing -> Either HieDbErr a -> IO (Either HieDbErr a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either HieDbErr a -> IO (Either HieDbErr a))
-> Either HieDbErr a -> IO (Either HieDbErr a)
forall a b. (a -> b) -> a -> b
$ HieDbErr -> Either HieDbErr a
forall a b. a -> Either a b
Left (ModuleName -> Maybe UnitId -> HieDbErr
NotIndexed ModuleName
mn (Maybe UnitId -> HieDbErr) -> Maybe UnitId -> HieDbErr
forall a b. (a -> b) -> a -> b
$ UnitId -> Maybe UnitId
forall a. a -> Maybe a
Just UnitId
uid)
          Just HieModuleRow
modRow -> FilePath -> IO (Either HieDbErr a)
forall a. FilePath -> IO (Either a a)
processHieFile (HieModuleRow -> FilePath
hieModuleHieFile HieModuleRow
modRow)
  where
    processHieFile :: FilePath -> IO (Either a a)
processHieFile FilePath
fp = do
      FilePath
fp' <- FilePath -> IO FilePath
canonicalizePath FilePath
fp
      IORef NameCache
nc <- NameCache -> IO (IORef NameCache)
forall a. a -> IO (IORef a)
newIORef (NameCache -> IO (IORef NameCache))
-> IO NameCache -> IO (IORef NameCache)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO NameCache
makeNc
      IORef NameCache -> DbMonad (Either a a) -> IO (Either a a)
forall a. IORef NameCache -> DbMonad a -> IO a
runDbM IORef NameCache
nc (DbMonad (Either a a) -> IO (Either a a))
-> DbMonad (Either a a) -> IO (Either a a)
forall a b. (a -> b) -> a -> b
$ do
        HieDb -> FilePath -> DbMonadT IO ()
forall (m :: * -> *).
(MonadIO m, NameCacheMonad m) =>
HieDb -> FilePath -> m ()
addRefsFrom HieDb
conn FilePath
fp'
        a -> Either a a
forall a b. b -> Either a b
Right (a -> Either a a) -> DbMonadT IO a -> DbMonad (Either a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> (HieFile -> DbMonadT IO a) -> DbMonadT IO a
forall (m :: * -> *) a.
(NameCacheMonad m, MonadIO m) =>
FilePath -> (HieFile -> m a) -> m a
withHieFile FilePath
fp' (a -> DbMonadT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> DbMonadT IO a) -> (HieFile -> a) -> HieFile -> DbMonadT IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HieFile -> a
f)
  

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

declRefs :: HieDb -> IO ()
declRefs :: HieDb -> IO ()
declRefs HieDb
db = do
  AdjacencyMap Vertex
graph <- HieDb -> IO (AdjacencyMap Vertex)
getGraph HieDb
db
  FilePath -> FilePath -> IO ()
writeFile
    FilePath
"refs.dot"
    ( Style Vertex FilePath -> AdjacencyMap Vertex -> FilePath
forall s a g.
(IsString s, Monoid s, Ord a, ToGraph g, ToVertex g ~ a) =>
Style a s -> g -> s
export
        ( ( (Vertex -> FilePath) -> Style Vertex FilePath
forall s a. Monoid s => (a -> s) -> Style a s
defaultStyle ( \( FilePath
_, FilePath
hie, FilePath
occ, Int
_, Int
_, Int
_, Int
_ ) -> FilePath
hie FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
":" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
occ ) )
          { vertexAttributes :: Vertex -> [Attribute FilePath]
vertexAttributes = \( FilePath
mod', FilePath
_, FilePath
occ, Int
_, Int
_, Int
_, Int
_ ) ->
              [ FilePath
"label" FilePath -> FilePath -> Attribute FilePath
forall s. s -> s -> Attribute s
G.:= ( FilePath
mod' FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"." FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop Int
1 FilePath
occ )
              , FilePath
"fillcolor" FilePath -> FilePath -> Attribute FilePath
forall s. s -> s -> Attribute s
G.:= case FilePath
occ of (Char
'v':FilePath
_) -> FilePath
"red"; (Char
't':FilePath
_) -> FilePath
"blue";FilePath
_ -> FilePath
"black"
              ]
          }
        )
        AdjacencyMap Vertex
graph
    )

getGraph :: HieDb -> IO (AdjacencyMap Vertex)
getGraph :: HieDb -> IO (AdjacencyMap Vertex)
getGraph (HieDb -> Connection
getConn -> Connection
conn) = do
  [Vertex :. Vertex]
es <-
    Connection -> Query -> IO [Vertex :. Vertex]
forall r. FromRow r => Connection -> Query -> IO [r]
query_ Connection
conn Query
"SELECT  mods.mod,    decls.hieFile,    decls.occ,    decls.sl,    decls.sc,    decls.el,    decls.ec, \
                       \rmods.mod, ref_decl.hieFile, ref_decl.occ, ref_decl.sl, ref_decl.sc, ref_decl.el, ref_decl.ec \
                \FROM decls JOIN refs              ON refs.hieFile  = decls.hieFile \
                           \JOIN mods              ON mods.hieFile  = decls.hieFile \
                           \JOIN mods  AS rmods    ON rmods.mod = refs.mod AND rmods.unit = refs.unit AND rmods.is_boot = 0 \
                           \JOIN decls AS ref_decl ON ref_decl.hieFile = rmods.hieFile AND ref_decl.occ = refs.occ \
                \WHERE ((refs.sl > decls.sl) OR (refs.sl = decls.sl AND refs.sc >  decls.sc)) \
                  \AND ((refs.el < decls.el) OR (refs.el = decls.el AND refs.ec <= decls.ec))"
  [Vertex]
vs <-
    Connection -> Query -> IO [Vertex]
forall r. FromRow r => Connection -> Query -> IO [r]
query_ Connection
conn Query
"SELECT mods.mod, decls.hieFile, decls.occ, decls.sl, decls.sc, decls.el, decls.ec \
                   \FROM decls JOIN mods USING (hieFile)"
  AdjacencyMap Vertex -> IO (AdjacencyMap Vertex)
forall (m :: * -> *) a. Monad m => a -> m a
return (AdjacencyMap Vertex -> IO (AdjacencyMap Vertex))
-> AdjacencyMap Vertex -> IO (AdjacencyMap Vertex)
forall a b. (a -> b) -> a -> b
$ AdjacencyMap Vertex -> AdjacencyMap Vertex -> AdjacencyMap Vertex
forall a.
Ord a =>
AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a
overlay ( [Vertex] -> AdjacencyMap Vertex
forall a. Ord a => [a] -> AdjacencyMap a
vertices [Vertex]
vs ) ( [(Vertex, Vertex)] -> AdjacencyMap Vertex
forall a. Ord a => [(a, a)] -> AdjacencyMap a
edges ( ((Vertex :. Vertex) -> (Vertex, Vertex))
-> [Vertex :. Vertex] -> [(Vertex, Vertex)]
forall a b. (a -> b) -> [a] -> [b]
map (\( Vertex
x :. Vertex
y ) -> ( Vertex
x, Vertex
y )) [Vertex :. Vertex]
es ) )

getVertices :: HieDb -> [Symbol] -> IO [Vertex]
getVertices :: HieDb -> [Symbol] -> IO [Vertex]
getVertices (HieDb -> Connection
getConn -> Connection
conn) [Symbol]
ss = Set Vertex -> [Vertex]
forall a. Set a -> [a]
Set.toList (Set Vertex -> [Vertex]) -> IO (Set Vertex) -> IO [Vertex]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Set Vertex -> Symbol -> IO (Set Vertex))
-> Set Vertex -> [Symbol] -> IO (Set Vertex)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Set Vertex -> Symbol -> IO (Set Vertex)
f Set Vertex
forall a. Set a
Set.empty [Symbol]
ss
  where
    f :: Set Vertex -> Symbol -> IO (Set Vertex)
    f :: Set Vertex -> Symbol -> IO (Set Vertex)
f Set Vertex
vs Symbol
s = (Set Vertex -> Vertex -> Set Vertex)
-> Set Vertex -> [Vertex] -> Set Vertex
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((Vertex -> Set Vertex -> Set Vertex)
-> Set Vertex -> Vertex -> Set Vertex
forall a b c. (a -> b -> c) -> b -> a -> c
flip Vertex -> Set Vertex -> Set Vertex
forall a. Ord a => a -> Set a -> Set a
Set.insert) Set Vertex
vs ([Vertex] -> Set Vertex) -> IO [Vertex] -> IO (Set Vertex)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Symbol -> IO [Vertex]
one Symbol
s

    one :: Symbol -> IO [Vertex]
    one :: Symbol -> IO [Vertex]
one Symbol
s = do
      let n :: FilePath
n = NameSpace -> Char
toNsChar (OccName -> NameSpace
occNameSpace (OccName -> NameSpace) -> OccName -> NameSpace
forall a b. (a -> b) -> a -> b
$ Symbol -> OccName
symName Symbol
s) Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: OccName -> FilePath
occNameString (Symbol -> OccName
symName Symbol
s)
          m :: FilePath
m = ModuleName -> FilePath
moduleNameString (ModuleName -> FilePath) -> ModuleName -> FilePath
forall a b. (a -> b) -> a -> b
$ Module -> ModuleName
moduleName (Module -> ModuleName) -> Module -> ModuleName
forall a b. (a -> b) -> a -> b
$ Symbol -> Module
symModule Symbol
s
          u :: FilePath
u = UnitId -> FilePath
unitIdString (Module -> UnitId
moduleUnitId (Module -> UnitId) -> Module -> UnitId
forall a b. (a -> b) -> a -> b
$ Symbol -> Module
symModule Symbol
s)
      Connection
-> Query -> (FilePath, FilePath, FilePath) -> IO [Vertex]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query Connection
conn Query
"SELECT mods.mod, decls.hieFile, decls.occ, decls.sl, decls.sc, decls.el, decls.ec \
                 \FROM decls JOIN mods USING (hieFile) \
                 \WHERE ( decls.occ = ? AND mods.mod = ? AND mods.unit = ? ) " (FilePath
n, FilePath
m, FilePath
u)

getReachable :: HieDb -> [Symbol] -> IO [Vertex]
getReachable :: HieDb -> [Symbol] -> IO [Vertex]
getReachable HieDb
db [Symbol]
symbols = ([Vertex], [Vertex]) -> [Vertex]
forall a b. (a, b) -> a
fst (([Vertex], [Vertex]) -> [Vertex])
-> IO ([Vertex], [Vertex]) -> IO [Vertex]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HieDb -> [Symbol] -> IO ([Vertex], [Vertex])
getReachableUnreachable HieDb
db [Symbol]
symbols

getUnreachable :: HieDb -> [Symbol] -> IO [Vertex]
getUnreachable :: HieDb -> [Symbol] -> IO [Vertex]
getUnreachable HieDb
db [Symbol]
symbols = ([Vertex], [Vertex]) -> [Vertex]
forall a b. (a, b) -> b
snd (([Vertex], [Vertex]) -> [Vertex])
-> IO ([Vertex], [Vertex]) -> IO [Vertex]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HieDb -> [Symbol] -> IO ([Vertex], [Vertex])
getReachableUnreachable HieDb
db [Symbol]
symbols

html :: (NameCacheMonad m, MonadIO m) => HieDb -> [Symbol] -> m ()
html :: HieDb -> [Symbol] -> m ()
html HieDb
db [Symbol]
symbols = do
    Map FilePath (ModuleName, Set Span)
m <- IO (Map FilePath (ModuleName, Set Span))
-> m (Map FilePath (ModuleName, Set Span))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map FilePath (ModuleName, Set Span))
 -> m (Map FilePath (ModuleName, Set Span)))
-> IO (Map FilePath (ModuleName, Set Span))
-> m (Map FilePath (ModuleName, Set Span))
forall a b. (a -> b) -> a -> b
$ HieDb -> [Symbol] -> IO (Map FilePath (ModuleName, Set Span))
getAnnotations HieDb
db [Symbol]
symbols
    [(FilePath, (ModuleName, Set Span))]
-> ((FilePath, (ModuleName, Set Span)) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map FilePath (ModuleName, Set Span)
-> [(FilePath, (ModuleName, Set Span))]
forall k a. Map k a -> [(k, a)]
Map.toList Map FilePath (ModuleName, Set Span)
m) (((FilePath, (ModuleName, Set Span)) -> m ()) -> m ())
-> ((FilePath, (ModuleName, Set Span)) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(FilePath
fp, (ModuleName
mod', Set Span
sps)) -> do
        [Text]
code <- FilePath -> m [Text]
forall (m :: * -> *).
(NameCacheMonad m, MonadIO m) =>
FilePath -> m [Text]
sourceCode FilePath
fp
        let fp' :: FilePath
fp' = FilePath -> FilePath -> FilePath
replaceExtension FilePath
fp FilePath
"html"
        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ ModuleName -> FilePath
moduleNameString ModuleName
mod' FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
": " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
fp'
        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ModuleName -> [Text] -> [Span] -> IO ()
Html.generate FilePath
fp' ModuleName
mod' [Text]
code ([Span] -> IO ()) -> [Span] -> IO ()
forall a b. (a -> b) -> a -> b
$ Set Span -> [Span]
forall a. Set a -> [a]
Set.toList Set Span
sps

getAnnotations :: HieDb -> [Symbol] -> IO (Map FilePath (ModuleName, Set Html.Span))
getAnnotations :: HieDb -> [Symbol] -> IO (Map FilePath (ModuleName, Set Span))
getAnnotations HieDb
db [Symbol]
symbols = do
    ([Vertex]
rs, [Vertex]
us) <- HieDb -> [Symbol] -> IO ([Vertex], [Vertex])
getReachableUnreachable HieDb
db [Symbol]
symbols
    let m1 :: Map FilePath (ModuleName, Set Span)
m1 = (Map FilePath (ModuleName, Set Span)
 -> Vertex -> Map FilePath (ModuleName, Set Span))
-> Map FilePath (ModuleName, Set Span)
-> [Vertex]
-> Map FilePath (ModuleName, Set Span)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Color
-> Map FilePath (ModuleName, Set Span)
-> Vertex
-> Map FilePath (ModuleName, Set Span)
f Color
Html.Reachable)   Map FilePath (ModuleName, Set Span)
forall k a. Map k a
Map.empty [Vertex]
rs
        m2 :: Map FilePath (ModuleName, Set Span)
m2 = (Map FilePath (ModuleName, Set Span)
 -> Vertex -> Map FilePath (ModuleName, Set Span))
-> Map FilePath (ModuleName, Set Span)
-> [Vertex]
-> Map FilePath (ModuleName, Set Span)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Color
-> Map FilePath (ModuleName, Set Span)
-> Vertex
-> Map FilePath (ModuleName, Set Span)
f Color
Html.Unreachable) Map FilePath (ModuleName, Set Span)
m1        [Vertex]
us
    Map FilePath (ModuleName, Set Span)
-> IO (Map FilePath (ModuleName, Set Span))
forall (m :: * -> *) a. Monad m => a -> m a
return Map FilePath (ModuleName, Set Span)
m2
  where
    f :: Html.Color 
      -> Map FilePath (ModuleName, Set Html.Span) 
      -> Vertex 
      -> Map FilePath (ModuleName, Set Html.Span)
    f :: Color
-> Map FilePath (ModuleName, Set Span)
-> Vertex
-> Map FilePath (ModuleName, Set Span)
f Color
c Map FilePath (ModuleName, Set Span)
m Vertex
v =
        let (FilePath
fp, ModuleName
mod', Span
sp) = Color -> Vertex -> (FilePath, ModuleName, Span)
g Color
c Vertex
v
        in  ((ModuleName, Set Span)
 -> (ModuleName, Set Span) -> (ModuleName, Set Span))
-> FilePath
-> (ModuleName, Set Span)
-> Map FilePath (ModuleName, Set Span)
-> Map FilePath (ModuleName, Set Span)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith (ModuleName, Set Span)
-> (ModuleName, Set Span) -> (ModuleName, Set Span)
h FilePath
fp (ModuleName
mod', Span -> Set Span
forall a. a -> Set a
Set.singleton Span
sp) Map FilePath (ModuleName, Set Span)
m

    g :: Html.Color -> Vertex -> (FilePath, ModuleName, Html.Span)
    g :: Color -> Vertex -> (FilePath, ModuleName, Span)
g Color
c (FilePath
mod', FilePath
fp, FilePath
_, Int
sl, Int
sc, Int
el, Int
ec) = (FilePath
fp, FilePath -> ModuleName
mkModuleName FilePath
mod', Span :: Int -> Int -> Int -> Int -> Color -> Span
Html.Span
        { spStartLine :: Int
Html.spStartLine   = Int
sl
        , spStartColumn :: Int
Html.spStartColumn = Int
sc
        , spEndLine :: Int
Html.spEndLine     = Int
el
        , spEndColumn :: Int
Html.spEndColumn   = Int
ec
        , spColor :: Color
Html.spColor       = Color
c
        })

    h :: (ModuleName, Set Html.Span)
      -> (ModuleName, Set Html.Span)
      -> (ModuleName, Set Html.Span)
    h :: (ModuleName, Set Span)
-> (ModuleName, Set Span) -> (ModuleName, Set Span)
h (ModuleName
m, Set Span
sps) (ModuleName
_, Set Span
sps') = (ModuleName
m, Set Span
sps Set Span -> Set Span -> Set Span
forall a. Semigroup a => a -> a -> a
<> Set Span
sps')

getReachableUnreachable :: HieDb -> [Symbol] -> IO ([Vertex], [Vertex])
getReachableUnreachable :: HieDb -> [Symbol] -> IO ([Vertex], [Vertex])
getReachableUnreachable HieDb
db [Symbol]
symbols = do
  [Vertex]
vs <- HieDb -> [Symbol] -> IO [Vertex]
getVertices HieDb
db [Symbol]
symbols
  AdjacencyMap Vertex
graph  <- HieDb -> IO (AdjacencyMap Vertex)
getGraph HieDb
db
  let (Set Vertex
xs, Set Vertex
ys) = AdjacencyMap Vertex -> [Vertex] -> (Set Vertex, Set Vertex)
forall a. Ord a => AdjacencyMap a -> [a] -> (Set a, Set a)
splitByReachability AdjacencyMap Vertex
graph [Vertex]
vs
  ([Vertex], [Vertex]) -> IO ([Vertex], [Vertex])
forall (m :: * -> *) a. Monad m => a -> m a
return (Set Vertex -> [Vertex]
forall a. Set a -> [a]
Set.toList Set Vertex
xs, Set Vertex -> [Vertex]
forall a. Set a -> [a]
Set.toList Set Vertex
ys)

splitByReachability :: Ord a => AdjacencyMap a -> [a] -> (Set a, Set a)
splitByReachability :: AdjacencyMap a -> [a] -> (Set a, Set a)
splitByReachability AdjacencyMap a
m [a]
vs = let s :: Set a
s = [a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList ([a] -> AdjacencyMap a -> [a]
forall a. Ord a => [a] -> AdjacencyMap a -> [a]
dfs [a]
vs AdjacencyMap a
m) in (Set a
s, AdjacencyMap a -> Set a
forall a. AdjacencyMap a -> Set a
vertexSet AdjacencyMap a
m Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set a
s)