{-# 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 Control.Monad.State.Strict (evalStateT)
import qualified Data.Array as A
import qualified Data.Map as M
import qualified Data.IntMap.Strict as IMap
import Data.Int
import Data.List ( isSuffixOf )
import Data.Maybe
import Data.String
import System.Directory
import System.FilePath
import Database.SQLite.Simple
import HieDb.Compat as Compat
import HieDb.Types
import HieDb.Utils
sCHEMA_VERSION :: Integer
sCHEMA_VERSION :: Integer
sCHEMA_VERSION = Integer
8
dB_VERSION :: Integer
dB_VERSION :: Integer
dB_VERSION = FilePath -> Integer
forall a. Read a => FilePath -> a
read (Integer -> FilePath
forall a. Show a => a -> FilePath
show Integer
sCHEMA_VERSION FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"999" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Integer -> FilePath
forall a. Show a => a -> FilePath
show Integer
hieVersion)
checkVersion :: (HieDb -> IO a) -> HieDb -> IO a
checkVersion :: forall a. (HieDb -> IO a) -> HieDb -> IO a
checkVersion HieDb -> IO a
k db :: HieDb
db@(HieDb -> Connection
getConn -> Connection
conn) = do
Connection -> Query -> IO ()
execute_ Connection
conn Query
"PRAGMA busy_timeout = 500;"
Connection -> Query -> IO ()
execute_ Connection
conn Query
"PRAGMA journal_mode = WAL;"
[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
$ FilePath -> Query
forall a. IsString a => FilePath -> a
fromString (FilePath -> Query) -> FilePath -> Query
forall a b. (a -> b) -> a -> b
$ FilePath
"PRAGMA user_version = " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Integer -> FilePath
forall a. Show a => a -> FilePath
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
withHieDb :: FilePath -> (HieDb -> IO a) -> IO a
withHieDb :: forall a. FilePath -> (HieDb -> IO a) -> IO a
withHieDb FilePath
fp HieDb -> IO a
f = FilePath -> (Connection -> IO a) -> IO a
forall a. FilePath -> (Connection -> IO a) -> IO a
withConnection FilePath
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)
withHieDbAndFlags :: LibDir -> FilePath -> (DynFlags -> HieDb -> IO a) -> IO a
withHieDbAndFlags :: forall a. LibDir -> FilePath -> (DynFlags -> HieDb -> IO a) -> IO a
withHieDbAndFlags LibDir
libdir FilePath
fp DynFlags -> HieDb -> IO a
f = do
DynFlags
dynFlags <- LibDir -> IO DynFlags
dynFlagsForPrinting LibDir
libdir
FilePath -> (Connection -> IO a) -> IO a
forall a. FilePath -> (Connection -> IO a) -> IO a
withConnection FilePath
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)
initConn :: HieDb -> IO ()
initConn :: HieDb -> IO ()
initConn (HieDb -> Connection
getConn -> Connection
conn) = do
Connection -> Query -> IO ()
execute_ Connection
conn Query
"PRAGMA busy_timeout = 500;"
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 INDEX IF NOT EXISTS mod_unit ON mods(unit)"
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 imports \
\( hieFile TEXT NOT NULL \
\, mod 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 imports_mod ON imports(mod)"
Connection -> Query -> IO ()
execute_ Connection
conn Query
"CREATE INDEX IF NOT EXISTS imports_hiefile ON imports(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)"
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 a. a -> IO a
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 a. a -> IO a
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
forall unit. GenModule unit -> ModuleName
moduleName Module
m
uid :: Unit
uid = Module -> Unit
forall unit. GenModule unit -> 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)
(Only Int64 -> Int64) -> Maybe (Only Int64) -> Maybe Int64
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Only Int64 -> Int64
forall a. Only a -> a
fromOnly (Maybe (Only Int64) -> Maybe Int64)
-> ([Only Int64] -> Maybe (Only Int64))
-> [Only Int64]
-> Maybe Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Only Int64] -> Maybe (Only Int64)
forall a. [a] -> Maybe a
listToMaybe ([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)
addTypeRefs
:: HieDb
-> FilePath
-> HieFile
-> A.Array TypeIndex (Maybe Int64)
-> IO ()
addTypeRefs :: HieDb
-> FilePath -> HieFile -> Array TypeIndex (Maybe Int64) -> IO ()
addTypeRefs HieDb
db FilePath
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
(StateT (IntMap IntSet) IO () -> IntMap IntSet -> IO ())
-> IntMap IntSet -> StateT (IntMap IntSet) IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT (IntMap IntSet) IO () -> IntMap IntSet -> IO ()
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT IntMap IntSet
forall a. IntMap a
IMap.empty
(StateT (IntMap IntSet) IO () -> IO ())
-> StateT (IntMap IntSet) IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (TypeIndex -> StateT (IntMap IntSet) IO ())
-> [TypeIndex] -> StateT (IntMap IntSet) IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (HieDb
-> FilePath
-> Array TypeIndex HieTypeFlat
-> Array TypeIndex (Maybe Int64)
-> RealSrcSpan
-> TypeIndex
-> StateT (IntMap IntSet) IO ()
addTypeRef HieDb
db FilePath
path Array TypeIndex HieTypeFlat
arr Array TypeIndex (Maybe Int64)
ixs (HieAST TypeIndex -> RealSrcSpan
forall a. HieAST a -> RealSrcSpan
nodeSpan HieAST TypeIndex
ast))
([TypeIndex] -> StateT (IntMap IntSet) IO ())
-> [TypeIndex] -> StateT (IntMap IntSet) 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 (Bool -> Bool
not ((ContextInfo -> Bool) -> Set ContextInfo -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ContextInfo -> Bool
isOccurrence (IdentifierDetails TypeIndex -> Set ContextInfo
forall a. IdentifierDetails a -> Set ContextInfo
identInfo IdentifierDetails TypeIndex
x))) Maybe () -> Maybe TypeIndex -> Maybe TypeIndex
forall a b. Maybe a -> Maybe b -> Maybe b
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
data SkipOptions =
SkipOptions
{ SkipOptions -> Bool
skipRefs :: Bool
, SkipOptions -> Bool
skipDecls :: Bool
, SkipOptions -> Bool
skipDefs :: Bool
, SkipOptions -> Bool
skipExports :: Bool
, SkipOptions -> Bool
skipImports :: Bool
, SkipOptions -> Bool
skipTypes :: Bool
, SkipOptions -> Bool
skipTypeRefs :: Bool
}
deriving TypeIndex -> SkipOptions -> FilePath -> FilePath
[SkipOptions] -> FilePath -> FilePath
SkipOptions -> FilePath
(TypeIndex -> SkipOptions -> FilePath -> FilePath)
-> (SkipOptions -> FilePath)
-> ([SkipOptions] -> FilePath -> FilePath)
-> Show SkipOptions
forall a.
(TypeIndex -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: TypeIndex -> SkipOptions -> FilePath -> FilePath
showsPrec :: TypeIndex -> SkipOptions -> FilePath -> FilePath
$cshow :: SkipOptions -> FilePath
show :: SkipOptions -> FilePath
$cshowList :: [SkipOptions] -> FilePath -> FilePath
showList :: [SkipOptions] -> FilePath -> FilePath
Show
defaultSkipOptions :: SkipOptions
defaultSkipOptions :: SkipOptions
defaultSkipOptions =
SkipOptions
{ skipRefs :: Bool
skipRefs = Bool
False
, skipDecls :: Bool
skipDecls = Bool
False
, skipDefs :: Bool
skipDefs = Bool
False
, skipExports :: Bool
skipExports = Bool
False
, skipImports :: Bool
skipImports = Bool
False
, skipTypes :: Bool
skipTypes = Bool
False
, skipTypeRefs :: Bool
skipTypeRefs = Bool
False
}
addRefsFrom :: (MonadIO m, NameCacheMonad m) => HieDb -> Maybe FilePath -> SkipOptions -> FilePath -> m Bool
addRefsFrom :: forall (m :: * -> *).
(MonadIO m, NameCacheMonad m) =>
HieDb -> Maybe FilePath -> SkipOptions -> FilePath -> m Bool
addRefsFrom c :: HieDb
c@(HieDb -> Connection
getConn -> Connection
conn) Maybe FilePath
mSrcBaseDir SkipOptions
skipOptions FilePath
path = do
Fingerprint
hash <- IO Fingerprint -> m Fingerprint
forall a. IO a -> m a
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
$ FilePath -> IO Fingerprint
getFileHash FilePath
path
[HieModuleRow]
mods <- IO [HieModuleRow] -> m [HieModuleRow]
forall a. IO a -> m a
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 -> (FilePath, 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 = ?" (FilePath
path, Fingerprint
hash)
case [HieModuleRow]
mods of
(HieModuleRow{}:[HieModuleRow]
_) -> Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
[] -> do
FilePath -> (HieFile -> m ()) -> m ()
forall (m :: * -> *) a.
(NameCacheMonad m, MonadIO m) =>
FilePath -> (HieFile -> m a) -> m a
withHieFile FilePath
path ((HieFile -> m ()) -> m ()) -> (HieFile -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ Fingerprint -> HieFile -> m ()
forall (m :: * -> *). MonadIO m => Fingerprint -> HieFile -> m ()
addRefsWithFile Fingerprint
hash
Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
where
addRefsWithFile :: MonadIO m => Fingerprint -> HieFile -> m ()
addRefsWithFile :: forall (m :: * -> *). MonadIO m => Fingerprint -> HieFile -> m ()
addRefsWithFile Fingerprint
hash HieFile
hieFile = do
SourceFile
srcfile <- IO SourceFile -> m SourceFile
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SourceFile -> m SourceFile) -> IO SourceFile -> m SourceFile
forall a b. (a -> b) -> a -> b
$
IO SourceFile
-> (FilePath -> IO SourceFile) -> Maybe FilePath -> IO SourceFile
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(SourceFile -> IO SourceFile
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SourceFile -> IO SourceFile)
-> (Maybe FilePath -> SourceFile)
-> Maybe FilePath
-> IO SourceFile
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe FilePath -> SourceFile
FakeFile (Maybe FilePath -> IO SourceFile)
-> Maybe FilePath -> IO SourceFile
forall a b. (a -> b) -> a -> b
$ Maybe FilePath
forall a. Maybe a
Nothing)
(\FilePath
srcBaseDir -> do
FilePath
srcFullPath <- FilePath -> IO FilePath
makeAbsolute (FilePath
srcBaseDir FilePath -> FilePath -> FilePath
</> HieFile -> FilePath
hie_hs_file HieFile
hieFile)
Bool
fileExists <- FilePath -> IO Bool
doesFileExist FilePath
srcFullPath
SourceFile -> IO SourceFile
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SourceFile -> IO SourceFile) -> SourceFile -> IO SourceFile
forall a b. (a -> b) -> a -> b
$ if Bool
fileExists then FilePath -> SourceFile
RealFile FilePath
srcFullPath else Maybe FilePath -> SourceFile
FakeFile Maybe FilePath
forall a. Maybe a
Nothing
)
Maybe FilePath
mSrcBaseDir
HieDb
-> FilePath
-> SourceFile
-> Fingerprint
-> SkipOptions
-> HieFile
-> m ()
forall (m :: * -> *).
MonadIO m =>
HieDb
-> FilePath
-> SourceFile
-> Fingerprint
-> SkipOptions
-> HieFile
-> m ()
addRefsFromLoadedInternal HieDb
c FilePath
path SourceFile
srcfile Fingerprint
hash SkipOptions
skipOptions HieFile
hieFile
addRefsFromLoaded
:: MonadIO m
=> HieDb
-> FilePath
-> SourceFile
-> Fingerprint
-> HieFile
-> m ()
addRefsFromLoaded :: forall (m :: * -> *).
MonadIO m =>
HieDb -> FilePath -> SourceFile -> Fingerprint -> HieFile -> m ()
addRefsFromLoaded HieDb
db FilePath
path SourceFile
sourceFile Fingerprint
hash HieFile
hf =
HieDb
-> FilePath
-> SourceFile
-> Fingerprint
-> SkipOptions
-> HieFile
-> m ()
forall (m :: * -> *).
MonadIO m =>
HieDb
-> FilePath
-> SourceFile
-> Fingerprint
-> SkipOptions
-> HieFile
-> m ()
addRefsFromLoadedInternal HieDb
db FilePath
path SourceFile
sourceFile Fingerprint
hash SkipOptions
defaultSkipOptions HieFile
hf
addRefsFromLoadedInternal
:: MonadIO m
=> HieDb
-> FilePath
-> SourceFile
-> Fingerprint
-> SkipOptions
-> HieFile
-> m ()
addRefsFromLoadedInternal :: forall (m :: * -> *).
MonadIO m =>
HieDb
-> FilePath
-> SourceFile
-> Fingerprint
-> SkipOptions
-> HieFile
-> m ()
addRefsFromLoadedInternal
db :: HieDb
db@(HieDb -> Connection
getConn -> Connection
conn) FilePath
path SourceFile
sourceFile Fingerprint
hash SkipOptions
skipOptions HieFile
hf =
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ 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 -> FilePath -> IO ()
deleteInternalTables Connection
conn FilePath
path
HieDb
-> FilePath
-> SourceFile
-> Fingerprint
-> SkipOptions
-> HieFile
-> IO ()
forall (m :: * -> *).
MonadIO m =>
HieDb
-> FilePath
-> SourceFile
-> Fingerprint
-> SkipOptions
-> HieFile
-> m ()
addRefsFromLoaded_unsafe HieDb
db FilePath
path SourceFile
sourceFile Fingerprint
hash SkipOptions
skipOptions HieFile
hf
addRefsFromLoaded_unsafe
:: MonadIO m
=> HieDb
-> FilePath
-> SourceFile
-> Fingerprint
-> SkipOptions
-> HieFile
-> m ()
addRefsFromLoaded_unsafe :: forall (m :: * -> *).
MonadIO m =>
HieDb
-> FilePath
-> SourceFile
-> Fingerprint
-> SkipOptions
-> HieFile
-> m ()
addRefsFromLoaded_unsafe
db :: HieDb
db@(HieDb -> Connection
getConn -> Connection
conn) FilePath
path SourceFile
sourceFile Fingerprint
hash SkipOptions
skipOptions HieFile
hf = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
let isBoot :: Bool
isBoot = FilePath
"boot" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` FilePath
path
mod :: ModuleName
mod = Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
smod
uid :: Unit
uid = Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
smod
smod :: Module
smod = HieFile -> Module
hie_module HieFile
hf
refmap :: RefMap TypeIndex
refmap = Map HiePath (HieAST TypeIndex) -> RefMap TypeIndex
forall (f :: * -> *) a. Foldable f => f (HieAST a) -> RefMap a
generateReferencesMap (Map HiePath (HieAST TypeIndex) -> RefMap TypeIndex)
-> Map HiePath (HieAST TypeIndex) -> RefMap 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 FilePath
srcFile, Bool
isReal) = case SourceFile
sourceFile of
RealFile FilePath
f -> (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
f, Bool
True)
FakeFile Maybe FilePath
mf -> (Maybe FilePath
mf, Bool
False)
modrow :: HieModuleRow
modrow = FilePath -> ModuleInfo -> HieModuleRow
HieModuleRow FilePath
path (ModuleName
-> Unit
-> Bool
-> Maybe FilePath
-> Bool
-> Fingerprint
-> ModuleInfo
ModuleInfo ModuleName
mod Unit
uid Bool
isBoot Maybe FilePath
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 AstInfo [RefRow]
rows [DeclRow]
decls [ImportRow]
imports = FilePath -> Module -> RefMap TypeIndex -> AstInfo
forall a.
FilePath
-> Module
-> Map Identifier [(RealSrcSpan, IdentifierDetails a)]
-> AstInfo
genAstInfo FilePath
path Module
smod RefMap TypeIndex
refmap
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (SkipOptions -> Bool
skipRefs SkipOptions
skipOptions) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Connection -> Query -> [RefRow] -> IO ()
forall q. ToRow q => Connection -> Query -> [q] -> IO ()
executeMany Connection
conn Query
"INSERT INTO refs VALUES (?,?,?,?,?,?,?,?)" [RefRow]
rows
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (SkipOptions -> Bool
skipDecls SkipOptions
skipOptions) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Connection -> Query -> [DeclRow] -> IO ()
forall q. ToRow q => Connection -> Query -> [q] -> IO ()
executeMany Connection
conn Query
"INSERT INTO decls VALUES (?,?,?,?,?,?,?)" [DeclRow]
decls
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (SkipOptions -> Bool
skipImports SkipOptions
skipOptions) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Connection -> Query -> [ImportRow] -> IO ()
forall q. ToRow q => Connection -> Query -> [q] -> IO ()
executeMany Connection
conn Query
"INSERT INTO imports VALUES (?,?,?,?,?,?)" [ImportRow]
imports
let defs :: [DefRow]
defs = FilePath -> Module -> RefMap TypeIndex -> [DefRow]
forall a.
FilePath
-> Module
-> Map Identifier [(RealSrcSpan, IdentifierDetails a)]
-> [DefRow]
genDefRow FilePath
path Module
smod RefMap TypeIndex
refmap
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (SkipOptions -> Bool
skipDefs SkipOptions
skipOptions) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
[DefRow] -> (DefRow -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [DefRow]
defs ((DefRow -> IO ()) -> IO ()) -> (DefRow -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \DefRow
def ->
Connection -> Query -> DefRow -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
execute Connection
conn Query
"INSERT INTO defs VALUES (?,?,?,?,?,?)" DefRow
def
let exports :: [ExportRow]
exports = FilePath -> [AvailInfo] -> [ExportRow]
generateExports FilePath
path ([AvailInfo] -> [ExportRow]) -> [AvailInfo] -> [ExportRow]
forall a b. (a -> b) -> a -> b
$ HieFile -> [AvailInfo]
hie_exports HieFile
hf
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (SkipOptions -> Bool
skipExports SkipOptions
skipOptions) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Connection -> Query -> [ExportRow] -> IO ()
forall q. ToRow q => Connection -> Query -> [q] -> IO ()
executeMany Connection
conn Query
"INSERT INTO exports VALUES (?,?,?,?,?,?,?,?)" [ExportRow]
exports
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (SkipOptions -> Bool
skipTypes SkipOptions
skipOptions) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
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)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (SkipOptions -> Bool
skipTypeRefs SkipOptions
skipOptions) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
HieDb
-> FilePath -> HieFile -> Array TypeIndex (Maybe Int64) -> IO ()
addTypeRefs HieDb
db FilePath
path HieFile
hf Array TypeIndex (Maybe Int64)
ixs
addSrcFile
:: HieDb
-> FilePath
-> FilePath
-> Bool
-> IO ()
addSrcFile :: HieDb -> FilePath -> FilePath -> Bool -> IO ()
addSrcFile (HieDb -> Connection
getConn -> Connection
conn) FilePath
hie FilePath
srcFile Bool
isReal =
Connection -> Query -> (FilePath, Bool, FilePath) -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
execute Connection
conn Query
"UPDATE mods SET hs_src = ? , is_real = ? WHERE hieFile = ?" (FilePath
srcFile, Bool
isReal, FilePath
hie)
removeDependencySrcFiles
:: HieDb
-> IO ()
removeDependencySrcFiles :: HieDb -> IO ()
removeDependencySrcFiles (HieDb -> Connection
getConn -> Connection
conn) =
Connection -> Query -> () -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
execute Connection
conn Query
"UPDATE mods SET hs_src = NULL WHERE NOT is_real" ()
deleteFileFromIndex :: HieDb -> FilePath -> IO ()
deleteFileFromIndex :: HieDb -> FilePath -> IO ()
deleteFileFromIndex (HieDb -> Connection
getConn -> Connection
conn) FilePath
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 -> FilePath -> IO ()
deleteInternalTables Connection
conn FilePath
path
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
[FilePath]
missing_file_keys <- Connection
-> Query
-> [FilePath]
-> ([FilePath] -> (FilePath, FilePath) -> IO [FilePath])
-> IO [FilePath]
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" [] (([FilePath] -> (FilePath, FilePath) -> IO [FilePath])
-> IO [FilePath])
-> ([FilePath] -> (FilePath, FilePath) -> IO [FilePath])
-> IO [FilePath]
forall a b. (a -> b) -> a -> b
$
\[FilePath]
acc (FilePath
path,FilePath
src) -> do
Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
src
[FilePath] -> IO [FilePath]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ if Bool
exists then [FilePath]
acc else FilePath
path FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
acc
[FilePath] -> (FilePath -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
missing_file_keys ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FilePath
path -> do
Connection -> FilePath -> IO ()
deleteInternalTables Connection
conn FilePath
path
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 -> FilePath -> IO ()
deleteInternalTables Connection
conn FilePath
path = do
Connection -> Query -> Only FilePath -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
execute Connection
conn Query
"DELETE FROM refs WHERE hieFile = ?" (FilePath -> Only FilePath
forall a. a -> Only a
Only FilePath
path)
Connection -> Query -> Only FilePath -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
execute Connection
conn Query
"DELETE FROM decls WHERE hieFile = ?" (FilePath -> Only FilePath
forall a. a -> Only a
Only FilePath
path)
Connection -> Query -> Only FilePath -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
execute Connection
conn Query
"DELETE FROM defs WHERE hieFile = ?" (FilePath -> Only FilePath
forall a. a -> Only a
Only FilePath
path)
Connection -> Query -> Only FilePath -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
execute Connection
conn Query
"DELETE FROM typerefs WHERE hieFile = ?" (FilePath -> Only FilePath
forall a. a -> Only a
Only FilePath
path)
Connection -> Query -> Only FilePath -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
execute Connection
conn Query
"DELETE FROM mods WHERE hieFile = ?" (FilePath -> Only FilePath
forall a. a -> Only a
Only FilePath
path)
Connection -> Query -> Only FilePath -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
execute Connection
conn Query
"DELETE FROM exports WHERE hieFile = ?" (FilePath -> Only FilePath
forall a. a -> Only a
Only FilePath
path)