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

import Prelude hiding (mod)

import Compat.HieTypes
import Compat.HieUtils

import GHC

import Control.Exception
import Control.Monad
import Control.Monad.IO.Class

import qualified Data.Array as A
import qualified Data.Map as M

import Data.Int
import Data.List ( isSuffixOf )
import Data.Maybe
import Data.String

import System.Directory

import Database.SQLite.Simple

import HieDb.Compat as Compat
import HieDb.Types
import HieDb.Utils

sCHEMA_VERSION :: Integer
sCHEMA_VERSION :: Integer
sCHEMA_VERSION = Integer
6

dB_VERSION :: Integer
dB_VERSION :: Integer
dB_VERSION = String -> Integer
forall a. Read a => String -> a
read (Integer -> String
forall a. Show a => a -> String
show Integer
sCHEMA_VERSION String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"999" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
hieVersion)

{-| @checkVersion f db@ checks the schema version associated with given @db@.
If that version is supported by hiedb, it runs the function @f@ with the @db@.
Otherwise it throws 'IncompatibleSchemaVersion' exception.
-}
checkVersion :: (HieDb -> IO a) -> HieDb -> IO a
checkVersion :: (HieDb -> IO a) -> HieDb -> IO a
checkVersion HieDb -> IO a
k db :: HieDb
db@(HieDb -> Connection
getConn -> Connection
conn) = do
  [Only Integer
ver] <- Connection -> Query -> IO [Only Integer]
forall r. FromRow r => Connection -> Query -> IO [r]
query_ Connection
conn Query
"PRAGMA user_version"
  if Integer
ver Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 then do
    Connection -> Query -> IO ()
execute_ Connection
conn (Query -> IO ()) -> Query -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Query
forall a. IsString a => String -> a
fromString (String -> Query) -> String -> Query
forall a b. (a -> b) -> a -> b
$ String
"PRAGMA user_version = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
dB_VERSION
    HieDb -> IO a
k HieDb
db
  else if Integer
ver Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
dB_VERSION then do
    HieDb -> IO a
k HieDb
db
  else
    HieDbException -> IO a
forall e a. Exception e => e -> IO a
throwIO (HieDbException -> IO a) -> HieDbException -> IO a
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> HieDbException
IncompatibleSchemaVersion Integer
dB_VERSION Integer
ver

{-| Given path to @.hiedb@ file, constructs 'HieDb' and passes it to given function. -}
withHieDb :: FilePath -> (HieDb -> IO a) -> IO a
withHieDb :: String -> (HieDb -> IO a) -> IO a
withHieDb String
fp HieDb -> IO a
f = String -> (Connection -> IO a) -> IO a
forall a. String -> (Connection -> IO a) -> IO a
withConnection String
fp ((HieDb -> IO a) -> HieDb -> IO a
forall a. (HieDb -> IO a) -> HieDb -> IO a
checkVersion HieDb -> IO a
f (HieDb -> IO a) -> (Connection -> HieDb) -> Connection -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection -> HieDb
HieDb)

{-| Given GHC LibDir and path to @.hiedb@ file,
constructs DynFlags (required for printing info from @.hie@ files)
and 'HieDb' and passes them to given function.
-}
withHieDbAndFlags :: LibDir -> FilePath -> (DynFlags -> HieDb -> IO a) -> IO a
withHieDbAndFlags :: LibDir -> String -> (DynFlags -> HieDb -> IO a) -> IO a
withHieDbAndFlags LibDir
libdir String
fp DynFlags -> HieDb -> IO a
f = do
  DynFlags
dynFlags <- LibDir -> IO DynFlags
dynFlagsForPrinting LibDir
libdir
  String -> (Connection -> IO a) -> IO a
forall a. String -> (Connection -> IO a) -> IO a
withConnection String
fp ((HieDb -> IO a) -> HieDb -> IO a
forall a. (HieDb -> IO a) -> HieDb -> IO a
checkVersion (DynFlags -> HieDb -> IO a
f DynFlags
dynFlags) (HieDb -> IO a) -> (Connection -> HieDb) -> Connection -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection -> HieDb
HieDb)

{-| Initialize database schema for given 'HieDb'.
-}
initConn :: HieDb -> IO ()
initConn :: HieDb -> IO ()
initConn (HieDb -> Connection
getConn -> Connection
conn) = do
  Connection -> Query -> IO ()
execute_ Connection
conn Query
"PRAGMA journal_mode = WAL;"
  Connection -> Query -> IO ()
execute_ Connection
conn Query
"PRAGMA foreign_keys = ON;"
  Connection -> Query -> IO ()
execute_ Connection
conn Query
"PRAGMA defer_foreign_keys = ON;"

  Connection -> Query -> IO ()
execute_ Connection
conn Query
"CREATE TABLE IF NOT EXISTS mods \
                \( hieFile TEXT NOT NULL PRIMARY KEY ON CONFLICT REPLACE \
                \, mod     TEXT NOT NULL \
                \, unit    TEXT NOT NULL \
                \, is_boot BOOL NOT NULL \
                \, hs_src  TEXT UNIQUE ON CONFLICT REPLACE \
                \, is_real BOOL NOT NULL \
                \, hash    TEXT NOT NULL UNIQUE ON CONFLICT REPLACE \
                \, CONSTRAINT modid UNIQUE (mod, unit, is_boot) ON CONFLICT REPLACE \
                \, CONSTRAINT real_has_src CHECK ( (NOT is_real) OR (hs_src IS NOT NULL) ) \
                \)"
  Connection -> Query -> IO ()
execute_ Connection
conn Query
"CREATE INDEX IF NOT EXISTS mod_hash ON mods(hieFile,hash)"

  Connection -> Query -> IO ()
execute_ Connection
conn Query
"CREATE TABLE IF NOT EXISTS exports \
                \( hieFile TEXT NOT NULL \
                \, occ     TEXT NOT NULL \
                \, mod     TEXT NOT NULL \
                \, unit    TEXT NOT NULL \
                \, parent  TEXT \
                \, parentMod TEXT \
                \, parentUnit TEXT \
                \, is_datacon BOOL NOT NULL \
                \, FOREIGN KEY(hieFile) REFERENCES mods(hieFile) ON UPDATE CASCADE ON DELETE CASCADE DEFERRABLE INITIALLY DEFERRED \
                \)"
  Connection -> Query -> IO ()
execute_ Connection
conn Query
"CREATE INDEX IF NOT EXISTS exports_mod ON exports(hieFile)"

  Connection -> Query -> IO ()
execute_ Connection
conn Query
"CREATE TABLE IF NOT EXISTS refs \
                \( hieFile TEXT NOT NULL \
                \, occ     TEXT NOT NULL \
                \, mod     TEXT NOT NULL \
                \, unit    TEXT NOT NULL \
                \, sl   INTEGER NOT NULL \
                \, sc   INTEGER NOT NULL \
                \, el   INTEGER NOT NULL \
                \, ec   INTEGER NOT NULL \
                \, FOREIGN KEY(hieFile) REFERENCES mods(hieFile) ON UPDATE CASCADE ON DELETE CASCADE DEFERRABLE INITIALLY DEFERRED \
                \)"
  Connection -> Query -> IO ()
execute_ Connection
conn Query
"CREATE INDEX IF NOT EXISTS refs_mod ON refs(hieFile)"

  Connection -> Query -> IO ()
execute_ Connection
conn Query
"CREATE TABLE IF NOT EXISTS decls \
                \( hieFile    TEXT NOT NULL \
                \, occ        TEXT NOT NULL \
                \, sl      INTEGER NOT NULL \
                \, sc      INTEGER NOT NULL \
                \, el      INTEGER NOT NULL \
                \, ec      INTEGER NOT NULL \
                \, is_root    BOOL NOT NULL \
                \, FOREIGN KEY(hieFile) REFERENCES mods(hieFile) ON UPDATE CASCADE ON DELETE CASCADE DEFERRABLE INITIALLY DEFERRED \
                \)"
  Connection -> Query -> IO ()
execute_ Connection
conn Query
"CREATE INDEX IF NOT EXISTS decls_mod ON decls(hieFile)"

  Connection -> Query -> IO ()
execute_ Connection
conn Query
"CREATE TABLE IF NOT EXISTS defs \
                \( hieFile    TEXT NOT NULL \
                \, occ        TEXT NOT NULL \
                \, sl      INTEGER NOT NULL \
                \, sc      INTEGER NOT NULL \
                \, el      INTEGER NOT NULL \
                \, ec      INTEGER NOT NULL \
                \, FOREIGN KEY(hieFile) REFERENCES mods(hieFile) ON UPDATE CASCADE ON DELETE CASCADE DEFERRABLE INITIALLY DEFERRED \
                \, PRIMARY KEY(hieFile,occ) \
                \)"
  Connection -> Query -> IO ()
execute_ Connection
conn Query
"CREATE INDEX IF NOT EXISTS defs_mod ON defs(hieFile)"

  Connection -> Query -> IO ()
execute_ Connection
conn Query
"CREATE TABLE IF NOT EXISTS typenames \
                \( id      INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT \
                \, name       TEXT NOT NULL \
                \, mod        TEXT NOT NULL \
                \, unit       TEXT NOT NULL \
                \, CONSTRAINT uniqname UNIQUE (name, mod, unit) ON CONFLICT IGNORE \
                \)"

  Connection -> Query -> IO ()
execute_ Connection
conn Query
"CREATE TABLE IF NOT EXISTS typerefs \
                \( id   INTEGER NOT NULL \
                \, hieFile    TEXT NOT NULL \
                \, depth   INTEGER NOT NULL \
                \, sl      INTEGER NOT NULL \
                \, sc      INTEGER NOT NULL \
                \, el      INTEGER NOT NULL \
                \, ec      INTEGER NOT NULL \
                \, FOREIGN KEY(id) REFERENCES typenames(id) DEFERRABLE INITIALLY DEFERRED \
                \, FOREIGN KEY(hieFile) REFERENCES mods(hieFile) ON UPDATE CASCADE ON DELETE CASCADE DEFERRABLE INITIALLY DEFERRED \
                \)"
  Connection -> Query -> IO ()
execute_ Connection
conn Query
"CREATE INDEX IF NOT EXISTS typeref_id ON typerefs(id)"
  Connection -> Query -> IO ()
execute_ Connection
conn Query
"CREATE INDEX IF NOT EXISTS typerefs_mod ON typerefs(hieFile)"

{-| Add names of types from @.hie@ file to 'HieDb'.
Returns an Array mapping 'TypeIndex' to database ID assigned to the
corresponding record in DB.
-}
addArr :: HieDb -> A.Array TypeIndex HieTypeFlat -> IO (A.Array TypeIndex (Maybe Int64))
addArr :: HieDb
-> Array TypeIndex HieTypeFlat
-> IO (Array TypeIndex (Maybe Int64))
addArr (HieDb -> Connection
getConn -> Connection
conn) Array TypeIndex HieTypeFlat
arr = do
  Array TypeIndex HieTypeFlat
-> (HieTypeFlat -> IO (Maybe Int64))
-> IO (Array TypeIndex (Maybe Int64))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Array TypeIndex HieTypeFlat
arr ((HieTypeFlat -> IO (Maybe Int64))
 -> IO (Array TypeIndex (Maybe Int64)))
-> (HieTypeFlat -> IO (Maybe Int64))
-> IO (Array TypeIndex (Maybe Int64))
forall a b. (a -> b) -> a -> b
$ \case
    HTyVarTy Name
n -> Name -> IO (Maybe Int64)
addName Name
n
    HTyConApp IfaceTyCon
tc HieArgs TypeIndex
_ -> Name -> IO (Maybe Int64)
addName (IfaceTyCon -> Name
ifaceTyConName IfaceTyCon
tc)
    HieTypeFlat
_ -> Maybe Int64 -> IO (Maybe Int64)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Int64
forall a. Maybe a
Nothing
  where
    addName :: Name -> IO (Maybe Int64)
    addName :: Name -> IO (Maybe Int64)
addName Name
n = case Name -> Maybe Module
nameModule_maybe Name
n of
      Maybe Module
Nothing -> Maybe Int64 -> IO (Maybe Int64)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Int64
forall a. Maybe a
Nothing
      Just Module
m -> do
        let occ :: OccName
occ = Name -> OccName
nameOccName Name
n
            mod :: ModuleName
mod = Module -> ModuleName
moduleName Module
m
            uid :: Unit
uid = Module -> Unit
moduleUnit Module
m
        Connection -> Query -> (OccName, ModuleName, Unit) -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
execute Connection
conn Query
"INSERT INTO typenames(name,mod,unit) VALUES (?,?,?)" (OccName
occ,ModuleName
mod,Unit
uid)
        Int64 -> Maybe Int64
forall a. a -> Maybe a
Just (Int64 -> Maybe Int64)
-> ([Only Int64] -> Int64) -> [Only Int64] -> Maybe Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Only Int64 -> Int64
forall a. Only a -> a
fromOnly (Only Int64 -> Int64)
-> ([Only Int64] -> Only Int64) -> [Only Int64] -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Only Int64] -> Only Int64
forall a. [a] -> a
head ([Only Int64] -> Maybe Int64)
-> IO [Only Int64] -> IO (Maybe Int64)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection
-> Query -> (OccName, ModuleName, Unit) -> IO [Only Int64]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query Connection
conn Query
"SELECT id FROM typenames WHERE name = ? AND mod = ? AND unit = ?" (OccName
occ,ModuleName
mod,Unit
uid)

{-| Add references to types from given @.hie@ file to DB. -}
addTypeRefs
  :: HieDb
  -> FilePath -- ^ Path to @.hie@ file
  -> HieFile -- ^ Data loaded from the @.hie@ file
  -> A.Array TypeIndex (Maybe Int64) -- ^ Maps TypeIndex to database ID assigned to record in @typenames@ table
  -> IO ()
addTypeRefs :: HieDb
-> String -> HieFile -> Array TypeIndex (Maybe Int64) -> IO ()
addTypeRefs HieDb
db String
path HieFile
hf Array TypeIndex (Maybe Int64)
ixs = (HieAST TypeIndex -> IO ())
-> Map HiePath (HieAST TypeIndex) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ HieAST TypeIndex -> IO ()
addTypesFromAst Map HiePath (HieAST TypeIndex)
asts
  where
    arr :: A.Array TypeIndex HieTypeFlat
    arr :: Array TypeIndex HieTypeFlat
arr = HieFile -> Array TypeIndex HieTypeFlat
hie_types HieFile
hf
    asts :: M.Map HiePath (HieAST TypeIndex)
    asts :: Map HiePath (HieAST TypeIndex)
asts = HieASTs TypeIndex -> Map HiePath (HieAST TypeIndex)
forall a. HieASTs a -> Map HiePath (HieAST a)
getAsts (HieASTs TypeIndex -> Map HiePath (HieAST TypeIndex))
-> HieASTs TypeIndex -> Map HiePath (HieAST TypeIndex)
forall a b. (a -> b) -> a -> b
$ HieFile -> HieASTs TypeIndex
hie_asts HieFile
hf
    addTypesFromAst :: HieAST TypeIndex -> IO ()
    addTypesFromAst :: HieAST TypeIndex -> IO ()
addTypesFromAst HieAST TypeIndex
ast = do
      (TypeIndex -> IO ()) -> [TypeIndex] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (HieDb
-> String
-> Array TypeIndex HieTypeFlat
-> Array TypeIndex (Maybe Int64)
-> RealSrcSpan
-> TypeIndex
-> IO ()
addTypeRef HieDb
db String
path Array TypeIndex HieTypeFlat
arr Array TypeIndex (Maybe Int64)
ixs (HieAST TypeIndex -> RealSrcSpan
forall a. HieAST a -> RealSrcSpan
nodeSpan HieAST TypeIndex
ast))
        ([TypeIndex] -> IO ()) -> [TypeIndex] -> IO ()
forall a b. (a -> b) -> a -> b
$ (IdentifierDetails TypeIndex -> Maybe TypeIndex)
-> [IdentifierDetails TypeIndex] -> [TypeIndex]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\IdentifierDetails TypeIndex
x -> Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ((ContextInfo -> Bool) -> Set ContextInfo -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not (Bool -> Bool) -> (ContextInfo -> Bool) -> ContextInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContextInfo -> Bool
isOccurrence) (IdentifierDetails TypeIndex -> Set ContextInfo
forall a. IdentifierDetails a -> Set ContextInfo
identInfo IdentifierDetails TypeIndex
x)) Maybe () -> Maybe TypeIndex -> Maybe TypeIndex
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> IdentifierDetails TypeIndex -> Maybe TypeIndex
forall a. IdentifierDetails a -> Maybe a
identType IdentifierDetails TypeIndex
x)
        ([IdentifierDetails TypeIndex] -> [TypeIndex])
-> [IdentifierDetails TypeIndex] -> [TypeIndex]
forall a b. (a -> b) -> a -> b
$ Map Identifier (IdentifierDetails TypeIndex)
-> [IdentifierDetails TypeIndex]
forall k a. Map k a -> [a]
M.elems
        (Map Identifier (IdentifierDetails TypeIndex)
 -> [IdentifierDetails TypeIndex])
-> Map Identifier (IdentifierDetails TypeIndex)
-> [IdentifierDetails TypeIndex]
forall a b. (a -> b) -> a -> b
$ NodeInfo TypeIndex -> Map Identifier (IdentifierDetails TypeIndex)
forall a. NodeInfo a -> NodeIdentifiers a
nodeIdentifiers
        (NodeInfo TypeIndex
 -> Map Identifier (IdentifierDetails TypeIndex))
-> NodeInfo TypeIndex
-> Map Identifier (IdentifierDetails TypeIndex)
forall a b. (a -> b) -> a -> b
$ HieAST TypeIndex -> NodeInfo TypeIndex
nodeInfo' HieAST TypeIndex
ast
      (HieAST TypeIndex -> IO ()) -> [HieAST TypeIndex] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ HieAST TypeIndex -> IO ()
addTypesFromAst ([HieAST TypeIndex] -> IO ()) -> [HieAST TypeIndex] -> IO ()
forall a b. (a -> b) -> a -> b
$ HieAST TypeIndex -> [HieAST TypeIndex]
forall a. HieAST a -> [HieAST a]
nodeChildren HieAST TypeIndex
ast

{-| Adds all references from given @.hie@ file to 'HieDb'.
The indexing is skipped if the file was not modified since the last time it was indexed.
The boolean returned is true if the file was actually indexed
-}
addRefsFrom :: (MonadIO m, NameCacheMonad m) => HieDb -> FilePath -> m Bool
addRefsFrom :: HieDb -> String -> m Bool
addRefsFrom c :: HieDb
c@(HieDb -> Connection
getConn -> Connection
conn) String
path = do
  Fingerprint
hash <- IO Fingerprint -> m Fingerprint
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Fingerprint -> m Fingerprint)
-> IO Fingerprint -> m Fingerprint
forall a b. (a -> b) -> a -> b
$ String -> IO Fingerprint
getFileHash String
path
  [HieModuleRow]
mods <- IO [HieModuleRow] -> m [HieModuleRow]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [HieModuleRow] -> m [HieModuleRow])
-> IO [HieModuleRow] -> m [HieModuleRow]
forall a b. (a -> b) -> a -> b
$ Connection -> Query -> (String, Fingerprint) -> IO [HieModuleRow]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query Connection
conn Query
"SELECT * FROM mods WHERE hieFile = ? AND hash = ?" (String
path, Fingerprint
hash)
  case [HieModuleRow]
mods of
    (HieModuleRow{}:[HieModuleRow]
_) -> Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    [] -> do
      String -> (HieFile -> m ()) -> m ()
forall (m :: * -> *) a.
(NameCacheMonad m, MonadIO m) =>
String -> (HieFile -> m a) -> m a
withHieFile String
path ((HieFile -> m ()) -> m ()) -> (HieFile -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ HieDb -> String -> SourceFile -> Fingerprint -> HieFile -> m ()
forall (m :: * -> *).
MonadIO m =>
HieDb -> String -> SourceFile -> Fingerprint -> HieFile -> m ()
addRefsFromLoaded HieDb
c String
path (Maybe String -> SourceFile
FakeFile Maybe String
forall a. Maybe a
Nothing) Fingerprint
hash
      Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

addRefsFromLoaded
  :: MonadIO m
  => HieDb -- ^ HieDb into which we're adding the file
  -> FilePath -- ^ Path to @.hie@ file
  -> SourceFile -- ^ Path to .hs file from which @.hie@ file was created
                -- Also tells us if this is a real source file?
                -- i.e. does it come from user's project (as opposed to from project's dependency)?
  -> Fingerprint -- ^ The hash of the @.hie@ file
  -> HieFile -- ^ Data loaded from the @.hie@ file
  -> m ()
addRefsFromLoaded :: HieDb -> String -> SourceFile -> Fingerprint -> HieFile -> m ()
addRefsFromLoaded
  db :: HieDb
db@(HieDb -> Connection
getConn -> Connection
conn) String
path SourceFile
sourceFile Fingerprint
hash HieFile
hf =
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Connection -> IO () -> IO ()
forall a. Connection -> IO a -> IO a
withTransaction Connection
conn (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Connection -> String -> IO ()
deleteInternalTables Connection
conn String
path
      HieDb -> String -> SourceFile -> Fingerprint -> HieFile -> IO ()
forall (m :: * -> *).
MonadIO m =>
HieDb -> String -> SourceFile -> Fingerprint -> HieFile -> m ()
addRefsFromLoaded_unsafe HieDb
db String
path SourceFile
sourceFile Fingerprint
hash HieFile
hf

-- | Like 'addRefsFromLoaded' but without:
--   1) using a transaction
--   2) cleaning up previous versions of the file
--
--   Mostly useful to index a new database from scratch as fast as possible
addRefsFromLoaded_unsafe
  :: MonadIO m
  => HieDb -- ^ HieDb into which we're adding the file
  -> FilePath -- ^ Path to @.hie@ file
  -> SourceFile -- ^ Path to .hs file from which @.hie@ file was created
                -- Also tells us if this is a real source file?
                -- i.e. does it come from user's project (as opposed to from project's dependency)?
  -> Fingerprint -- ^ The hash of the @.hie@ file
  -> HieFile -- ^ Data loaded from the @.hie@ file
  -> m ()
addRefsFromLoaded_unsafe :: HieDb -> String -> SourceFile -> Fingerprint -> HieFile -> m ()
addRefsFromLoaded_unsafe
 db :: HieDb
db@(HieDb -> Connection
getConn -> Connection
conn) String
path SourceFile
sourceFile Fingerprint
hash HieFile
hf = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do

  let isBoot :: Bool
isBoot = String
"boot" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
path
      mod :: ModuleName
mod    = Module -> ModuleName
moduleName Module
smod
      uid :: Unit
uid    = Module -> Unit
moduleUnit Module
smod
      smod :: Module
smod   = HieFile -> Module
hie_module HieFile
hf
      refmap :: Map Identifier [(RealSrcSpan, IdentifierDetails TypeIndex)]
refmap = Map HiePath (HieAST TypeIndex)
-> Map Identifier [(RealSrcSpan, IdentifierDetails TypeIndex)]
forall (f :: * -> *) a.
Foldable f =>
f (HieAST a) -> Map Identifier [(RealSrcSpan, IdentifierDetails a)]
generateReferencesMap (Map HiePath (HieAST TypeIndex)
 -> Map Identifier [(RealSrcSpan, IdentifierDetails TypeIndex)])
-> Map HiePath (HieAST TypeIndex)
-> Map Identifier [(RealSrcSpan, IdentifierDetails TypeIndex)]
forall a b. (a -> b) -> a -> b
$ HieASTs TypeIndex -> Map HiePath (HieAST TypeIndex)
forall a. HieASTs a -> Map HiePath (HieAST a)
getAsts (HieASTs TypeIndex -> Map HiePath (HieAST TypeIndex))
-> HieASTs TypeIndex -> Map HiePath (HieAST TypeIndex)
forall a b. (a -> b) -> a -> b
$ HieFile -> HieASTs TypeIndex
hie_asts HieFile
hf
      (Maybe String
srcFile, Bool
isReal) = case SourceFile
sourceFile of
        RealFile String
f -> (String -> Maybe String
forall a. a -> Maybe a
Just String
f, Bool
True)
        FakeFile Maybe String
mf -> (Maybe String
mf, Bool
False)
      modrow :: HieModuleRow
modrow = String -> ModuleInfo -> HieModuleRow
HieModuleRow String
path (ModuleName
-> Unit
-> Bool
-> Maybe String
-> Bool
-> Fingerprint
-> ModuleInfo
ModuleInfo ModuleName
mod Unit
uid Bool
isBoot Maybe String
srcFile Bool
isReal Fingerprint
hash)

  Connection -> Query -> HieModuleRow -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
execute Connection
conn Query
"INSERT INTO mods VALUES (?,?,?,?,?,?,?)" HieModuleRow
modrow

  let ([RefRow]
rows,[DeclRow]
decls) = String
-> Module
-> Map Identifier [(RealSrcSpan, IdentifierDetails TypeIndex)]
-> ([RefRow], [DeclRow])
forall a.
String
-> Module
-> Map Identifier [(RealSrcSpan, IdentifierDetails a)]
-> ([RefRow], [DeclRow])
genRefsAndDecls String
path Module
smod Map Identifier [(RealSrcSpan, IdentifierDetails TypeIndex)]
refmap
  Connection -> Query -> [RefRow] -> IO ()
forall q. ToRow q => Connection -> Query -> [q] -> IO ()
executeMany Connection
conn Query
"INSERT INTO refs  VALUES (?,?,?,?,?,?,?,?)" [RefRow]
rows
  Connection -> Query -> [DeclRow] -> IO ()
forall q. ToRow q => Connection -> Query -> [q] -> IO ()
executeMany Connection
conn Query
"INSERT INTO decls VALUES (?,?,?,?,?,?,?)" [DeclRow]
decls

  let defs :: [DefRow]
defs = String
-> Module
-> Map Identifier [(RealSrcSpan, IdentifierDetails TypeIndex)]
-> [DefRow]
forall a.
String
-> Module
-> Map Identifier [(RealSrcSpan, IdentifierDetails a)]
-> [DefRow]
genDefRow String
path Module
smod Map Identifier [(RealSrcSpan, IdentifierDetails TypeIndex)]
refmap
  Connection -> Query -> [DefRow] -> IO ()
forall q. ToRow q => Connection -> Query -> [q] -> IO ()
executeMany Connection
conn Query
"INSERT INTO defs VALUES (?,?,?,?,?,?)" [DefRow]
defs

  let exports :: [ExportRow]
exports = String -> [AvailInfo] -> [ExportRow]
generateExports String
path ([AvailInfo] -> [ExportRow]) -> [AvailInfo] -> [ExportRow]
forall a b. (a -> b) -> a -> b
$ HieFile -> [AvailInfo]
hie_exports HieFile
hf
  Connection -> Query -> [ExportRow] -> IO ()
forall q. ToRow q => Connection -> Query -> [q] -> IO ()
executeMany Connection
conn Query
"INSERT INTO exports VALUES (?,?,?,?,?,?,?,?)" [ExportRow]
exports

  Array TypeIndex (Maybe Int64)
ixs <- HieDb
-> Array TypeIndex HieTypeFlat
-> IO (Array TypeIndex (Maybe Int64))
addArr HieDb
db (HieFile -> Array TypeIndex HieTypeFlat
hie_types HieFile
hf)
  HieDb
-> String -> HieFile -> Array TypeIndex (Maybe Int64) -> IO ()
addTypeRefs HieDb
db String
path HieFile
hf Array TypeIndex (Maybe Int64)
ixs

{-| Add path to .hs source given path to @.hie@ file which has already been indexed.
No action is taken if the corresponding @.hie@ file has not been indexed yet.
-}
addSrcFile
  :: HieDb
  -> FilePath -- ^ Path to @.hie@ file
  -> FilePath -- ^ Path to .hs file to be added to DB
  -> Bool -- ^ Is this a real source file? I.e. does it come from user's project (as opposed to from project's dependency)?
  -> IO ()
addSrcFile :: HieDb -> String -> String -> Bool -> IO ()
addSrcFile (HieDb -> Connection
getConn -> Connection
conn) String
hie String
srcFile Bool
isReal =
  Connection -> Query -> (String, Bool, String) -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
execute Connection
conn Query
"UPDATE mods SET hs_src = ? , is_real = ? WHERE hieFile = ?" (String
srcFile, Bool
isReal, String
hie)

{-| Delete all occurrences of given @.hie@ file from the database -}
deleteFileFromIndex :: HieDb -> FilePath -> IO ()
deleteFileFromIndex :: HieDb -> String -> IO ()
deleteFileFromIndex (HieDb -> Connection
getConn -> Connection
conn) String
path = Connection -> IO () -> IO ()
forall a. Connection -> IO a -> IO a
withTransaction Connection
conn (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  Connection -> String -> IO ()
deleteInternalTables Connection
conn String
path

{-| Delete all entries associated with modules for which the 'modInfoSrcFile' doesn't exist
on the disk.
Doesn't delete it if there is no associated 'modInfoSrcFile'
-}
deleteMissingRealFiles :: HieDb -> IO ()
deleteMissingRealFiles :: HieDb -> IO ()
deleteMissingRealFiles (HieDb -> Connection
getConn -> Connection
conn) = Connection -> IO () -> IO ()
forall a. Connection -> IO a -> IO a
withTransaction Connection
conn (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  [String]
missing_file_keys <- Connection
-> Query
-> [String]
-> ([String] -> (String, String) -> IO [String])
-> IO [String]
forall row a.
FromRow row =>
Connection -> Query -> a -> (a -> row -> IO a) -> IO a
fold_ Connection
conn Query
"SELECT hieFile,hs_src FROM mods WHERE hs_src IS NOT NULL AND is_real" [] (([String] -> (String, String) -> IO [String]) -> IO [String])
-> ([String] -> (String, String) -> IO [String]) -> IO [String]
forall a b. (a -> b) -> a -> b
$
    \[String]
acc (String
path,String
src) -> do
      Bool
exists <- String -> IO Bool
doesFileExist String
src
      [String] -> IO [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ if Bool
exists then [String]
acc else String
path String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
acc
  [String] -> (String -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
missing_file_keys ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
path -> do
    Connection -> String -> IO ()
deleteInternalTables Connection
conn String
path

{-| Garbage collect typenames with no references - it is a good idea to call
this function after a sequence of database updates (inserts or deletes)
-}
garbageCollectTypeNames :: HieDb -> IO Int
garbageCollectTypeNames :: HieDb -> IO TypeIndex
garbageCollectTypeNames (HieDb -> Connection
getConn -> Connection
conn) = do
  Connection -> Query -> IO ()
execute_ Connection
conn Query
"DELETE FROM typenames WHERE NOT EXISTS ( SELECT 1 FROM typerefs WHERE typerefs.id = typenames.id LIMIT 1 )"
  Connection -> IO TypeIndex
changes Connection
conn

deleteInternalTables :: Connection -> FilePath -> IO ()
deleteInternalTables :: Connection -> String -> IO ()
deleteInternalTables Connection
conn String
path = do
  Connection -> Query -> Only String -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
execute Connection
conn Query
"DELETE FROM refs  WHERE hieFile = ?" (String -> Only String
forall a. a -> Only a
Only String
path)
  Connection -> Query -> Only String -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
execute Connection
conn Query
"DELETE FROM decls WHERE hieFile = ?" (String -> Only String
forall a. a -> Only a
Only String
path)
  Connection -> Query -> Only String -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
execute Connection
conn Query
"DELETE FROM defs  WHERE hieFile = ?" (String -> Only String
forall a. a -> Only a
Only String
path)
  Connection -> Query -> Only String -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
execute Connection
conn Query
"DELETE FROM typerefs WHERE hieFile = ?" (String -> Only String
forall a. a -> Only a
Only String
path)
  Connection -> Query -> Only String -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
execute Connection
conn Query
"DELETE FROM mods  WHERE hieFile = ?" (String -> Only String
forall a. a -> Only a
Only String
path)
  Connection -> Query -> Only String -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
execute Connection
conn Query
"DELETE FROM exports WHERE hieFile = ?" (String -> Only String
forall a. a -> Only a
Only String
path)