{-# LANGUAGE FlexibleContexts, OverloadedStrings, MultiParamTypeClasses, RankNTypes, TypeOperators, TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module HsDev.Database.Update (
Status(..), Progress(..), Task(..),
UpdateOptions(..),
UpdateM(..),
runUpdate,
postStatus, updater, runTask, runTasks, runTasks_,
scanModules, scanFile, scanFiles, scanFileContents, scanCabal, prepareSandbox, scanSandbox, scanPackageDb, scanPackageDbStack, scanProjectFile, scanProjectStack, scanProject, scanDirectory,
scanPackageDbStackDocs, scanDocs,
setModTypes, inferModTypes,
scan,
processEvents, updateEvents, applyUpdates,
cacheGhcWarnings, cachedWarnings,
module HsDev.Database.Update.Types,
module HsDev.Watcher,
module Control.Monad.Except
) where
import qualified Control.Concurrent.Async as A
import Control.Concurrent.MVar
import Control.DeepSeq
import Control.Exception (ErrorCall, evaluate, displayException)
import Control.Lens
import Control.Monad.Catch (catch, handle, MonadThrow, bracket_)
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.Writer
import Control.Monad.State (get, modify, runStateT)
import Data.Aeson
import Data.List (intercalate)
import Data.String (fromString)
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import Data.Maybe
import Data.Text (Text)
import Data.Time.Clock.POSIX
import qualified Data.Text as T
import System.FilePath
import qualified System.Log.Simple as Log
import Data.Maybe.JustIf
import HsDev.Error
import qualified HsDev.Database.SQLite as SQLite
import HsDev.Display
import HsDev.Inspect
import HsDev.Inspect.Order
import HsDev.PackageDb
import HsDev.Project
import HsDev.Sandbox
import qualified HsDev.Stack as S
import HsDev.Symbols
import HsDev.Tools.Ghc.Session hiding (Session, evaluate)
import HsDev.Tools.Ghc.Types (fileTypes, TypedExpr)
import HsDev.Tools.Types
import HsDev.Tools.HDocs
import qualified HsDev.Scan as S
import HsDev.Scan.Browse
import HsDev.Util (ordNub, fromJSON', uniqueBy, timer)
import qualified HsDev.Util as Util (withCurrentDirectory)
import HsDev.Server.Types (commandNotify, inSessionGhc, FileSource(..))
import HsDev.Server.Message
import HsDev.Database.Update.Types
import HsDev.Watcher
import Text.Format
import System.Directory.Paths
onStatus :: UpdateMonad m => m ()
onStatus = asks (view (updateOptions . updateTasks)) >>= commandNotify . Notification . toJSON . reverse
childTask :: UpdateMonad m => Task -> m a -> m a
childTask t = local (over (updateOptions . updateTasks) (t:))
transact :: SessionMonad m => m a -> m a
transact = SQLite.transaction_ SQLite.Immediate
runUpdate :: ServerMonadBase m => UpdateOptions -> UpdateM m a -> ClientM m a
runUpdate uopts act = Log.scope "update" $ do
(r, updatedMods) <- withUpdateState uopts $ \ust ->
runWriterT (runUpdateM act' `runReaderT` ust)
Log.sendLog Log.Debug $ "updated {} modules" ~~ length updatedMods
return r
where
act' = do
(r, _) <- listen act
when (view updateDocs uopts) $ do
Log.sendLog Log.Trace "forking inspecting source docs"
Log.sendLog Log.Warning "not implemented"
when (view updateInfer uopts) $ do
Log.sendLog Log.Trace "forking inferring types"
Log.sendLog Log.Warning "not implemented"
return r
postStatus :: UpdateMonad m => Task -> m ()
postStatus t = childTask t onStatus
updater :: UpdateMonad m => [ModuleLocation] -> m ()
updater mlocs = tell $!! mlocs
runTask :: (Display t, UpdateMonad m, NFData a) => String -> t -> m a -> m a
runTask action subj act = Log.scope "task" $ do
postStatus $ set taskStatus StatusWorking task
x <- childTask task act
x `deepseq` postStatus (set taskStatus StatusOk task)
return x
`catch`
(\e -> postStatus (set taskStatus (StatusError e) task) >> hsdevError e)
where
task = Task {
_taskName = action,
_taskStatus = StatusWorking,
_taskSubjectType = displayType subj,
_taskSubjectName = display subj,
_taskProgress = Nothing }
runTasks :: UpdateMonad m => [m a] -> m [a]
runTasks ts = liftM catMaybes $ zipWithM taskNum [1..] (map noErr ts) where
total = length ts
taskNum n = local setProgress where
setProgress = set (updateOptions . updateTasks . _head . taskProgress) (Just (Progress n total))
noErr v = hsdevIgnore Nothing (Just <$> v)
runTasks_ :: UpdateMonad m => [m ()] -> m ()
runTasks_ = void . runTasks
data PreloadFailure = PreloadFailure ModuleLocation Inspection HsDevError
instance NFData PreloadFailure where
rnf (PreloadFailure mloc insp err) = rnf mloc `seq` rnf insp `seq` rnf err
scanModules :: UpdateMonad m => [String] -> [S.ModuleToScan] -> m ()
scanModules opts ms = Log.scope "scan-modules" $ mapM_ (uncurry scanModules') grouped where
scanModules' mproj ms' = do
maybe (return ()) (sendUpdateAction . SQLite.updateProject) mproj
updater $ ms' ^.. each . _1
defines <- askSession sessionDefines
let
pload (mloc, mopts, mcts) = runTask "preloading" mloc $ do
mfcts <- maybe (S.getFileContents (mloc ^?! moduleFile)) (const $ return Nothing) mcts
insp <- liftIO $ fileInspection (mloc ^?! moduleFile) (opts ++ mopts)
case (mfcts ^? _Just . _1) of
Just tm -> Log.sendLog Log.Trace $ "using edited file contents, mtime = {}" ~~ show tm
Nothing -> return ()
let
inspection' = maybe insp (fileContentsInspection_ (opts ++ mopts)) $ mfcts ^? _Just . _1
dirtyTag' = maybe id (const $ inspectTag DirtyTag) $ mfcts ^? _Just . _1
mcts' = mplus mcts (mfcts ^? _Just . _2)
runInspect mloc $ withInspection (return inspection') $ dirtyTag' $ preload (mloc ^?! moduleFile) defines (opts ++ mopts) mcts'
ploaded <- runTasks (map pload ms')
sendUpdateAction $ void $ SQLite.upsertModules $ map (fmap (view asModule)) ploaded
let
mlocs' = ploaded ^.. each . inspected . preloadedId . moduleLocation
updater mlocs'
let
mcabal = mproj ^? _Just . projectCabal
(env, fixities) <- loadEnv mcabal
Log.sendLog Log.Trace $ "resolved environment: {} modules" ~~ M.size env
case orderBy (preview inspected) ploaded of
Left err -> Log.sendLog Log.Error ("failed order dependencies for files: {}" ~~ show err)
Right ordered -> do
(ms'', (updEnv, updFixities)) <- flip runStateT (env, fixities) $ runTasks (map inspect' ordered)
saveEnv mcabal updEnv updFixities
mlocs'' <- timer "updated scanned modules" $ do
Log.sendLog Log.Trace $ case mproj of
Just proj -> "inserting data for resolved modules of project: {}" ~~ proj
Nothing -> "inserting data for resolved standalone modules"
sendUpdateAction $ Log.scope "resolved" $ updateResolveds mcabal ms''
return (ms'' ^.. each . inspectedKey)
updater mlocs''
where
inspect' pmod = runTask "scanning" ploc $ Log.scope "module" $ do
(env', fixities') <- get
r <- continueInspect pmod $ \p -> do
resolved' <- msum [
resolveModule env' fixities' p,
do
lift (Log.sendLog Log.Trace ("error resolving module {}, falling to resolving just imports/scope" ~~ (p ^. preloadedId . moduleLocation)))
resolvePreloaded env' p]
eval resolved'
modify $ mappend (
maybe mempty resolvedEnv (r ^? inspected),
maybe mempty resolvedFixitiesTable (r ^? inspected))
return r
where
ploc = pmod ^?! inspected . preloadedId . moduleLocation
grouped = M.toList $ M.unionsWith (++) [M.singleton (m ^? _1 . moduleProject . _Just) [m] | m <- ms]
eval v = handle onError (v `deepseq` liftIO (evaluate v)) where
onError :: MonadThrow m => ErrorCall -> m a
onError = hsdevError . OtherError . displayException
scanFile :: UpdateMonad m => [String] -> Path -> BuildTool -> Bool -> Bool -> m ()
scanFile opts fpath tool scanProj scanDb = do
mproj <- fmap (set (_Just . projectBuildTool) tool) $ locateProjectInfo fpath
sbox <- maybe (return userDb) (inSessionGhc . getProjectPackageDbStack) mproj
when scanDb $ do
[SQLite.Only scanned] <- SQLite.query @_ @(SQLite.Only Bool) "select count(*) > 0 from package_dbs as pdbs where pdbs.package_db = ?;" (SQLite.Only (topPackageDb sbox))
unless scanned $ scanPackageDbStack opts sbox
case join (mproj `justIf` scanProj) of
Nothing -> scanFiles [(FileSource fpath Nothing, opts)]
Just proj -> scanProject opts tool (view projectCabal proj)
scanFiles :: UpdateMonad m => [(FileSource, [String])] -> m ()
scanFiles fsrcs = runTask "scanning" ("files" :: String) $ Log.scope "files" $ hsdevLiftIO $ do
Log.sendLog Log.Trace $ "scanning {} files" ~~ length fsrcs
fpaths' <- traverse (liftIO . canonicalize) $ map (fileSource . fst) fsrcs
forM_ fpaths' $ \fpath' -> do
ex <- liftIO $ fileExists fpath'
unless ex $ hsdevError $ FileNotFound fpath'
mlocs <- forM fpaths' $ \fpath' -> do
mids <- SQLite.query (SQLite.toQuery $ SQLite.qModuleId `mappend` SQLite.where_ ["mu.file == ?"]) (SQLite.Only fpath')
if length mids > 1
then return (head mids ^. moduleLocation)
else do
mproj <- locateProjectInfo fpath'
return $ FileModule fpath' mproj
let
filesMods = liftM concat $ forM fpaths' $ \fpath' -> SQLite.query "select m.id, m.file, m.cabal, m.install_dirs, m.package_name, m.package_version, m.installed_name, m.exposed, m.other_location, m.inspection_time, m.inspection_opts from modules as m where m.file == ?;" (SQLite.Only fpath')
scan filesMods [(mloc, opts, mcts) | (mloc, (FileSource _ mcts, opts)) <- zip mlocs fsrcs] [] $ \mlocs' -> do
mapM_ ((watch . flip watchModule) . view _1) mlocs'
S.ScanContents dmods _ _ <- fmap mconcat $ mapM (S.enumDependent . view (_1 . moduleFile . path)) mlocs'
Log.sendLog Log.Trace $ "dependent modules: {}" ~~ length dmods
scanModules [] (mlocs' ++ dmods)
scanFileContents :: UpdateMonad m => [String] -> Path -> Maybe Text -> m ()
scanFileContents opts fpath mcts = scanFiles [(FileSource fpath mcts, opts)]
scanCabal :: UpdateMonad m => [String] -> m ()
scanCabal opts = Log.scope "cabal" $ scanPackageDbStack opts userDb
prepareSandbox :: UpdateMonad m => Sandbox -> m ()
prepareSandbox sbox@(Sandbox StackTool fpath) = Log.scope "prepare" $ runTasks_ [
runTask "building dependencies" sbox $ void $ Util.withCurrentDirectory dir $ inSessionGhc $ S.buildDeps Nothing]
where
dir = takeDirectory $ view path fpath
prepareSandbox _ = return ()
scanSandbox :: UpdateMonad m => [String] -> Sandbox -> m ()
scanSandbox opts sbox = Log.scope "sandbox" $ do
pdbs <- inSessionGhc $ sandboxPackageDbStack sbox
scanPackageDbStack opts pdbs
scanPackageDb :: UpdateMonad m => [String] -> PackageDbStack -> m ()
scanPackageDb opts pdbs = runTask "scanning" (topPackageDb pdbs) $ Log.scope "package-db" $ do
pdbState <- liftIO $ readPackageDb (topPackageDb pdbs)
let
packageDbMods = S.fromList $ concat $ M.elems pdbState
packages' = M.keys pdbState
Log.sendLog Log.Trace $ "package-db state: {} modules" ~~ length packageDbMods
watch (\w -> watchPackageDb w pdbs opts)
pkgs <- SQLite.query "select package_name, package_version from package_dbs where package_db == ?;" (SQLite.Only $ topPackageDb pdbs)
if S.fromList packages' == S.fromList pkgs
then Log.sendLog Log.Trace "nothing changes, all packages the same"
else do
mlocs <- liftM
(filter (`S.member` packageDbMods)) $
(inSessionGhc $ listModules opts pdbs packages')
let
umlocs = uniqueModuleLocations mlocs
Log.sendLog Log.Trace $ "{} modules found, {} unique" ~~ length mlocs ~~ length umlocs
let
packageDbMods' = SQLite.query "select m.id, m.file, m.cabal, m.install_dirs, m.package_name, m.package_version, m.installed_name, m.exposed, m.other_location, m.inspection_time, m.inspection_opts from modules as m, package_dbs as ps where m.package_name == ps.package_name and m.package_version == ps.package_version and ps.package_db == ?;" (SQLite.Only (topPackageDb pdbs))
scan packageDbMods' ((,,) <$> umlocs <*> pure [] <*> pure Nothing) opts $ \mlocs' -> do
ms <- inSessionGhc $ browseModules opts pdbs (mlocs' ^.. each . _1)
Log.sendLog Log.Trace $ "scanned {} modules" ~~ length ms
sendUpdateAction $ timer "updated package-db modules" $ do
SQLite.updateModules ms
SQLite.updatePackageDb (topPackageDb pdbs) (M.keys pdbState)
when hdocsSupported $ scanPackageDbStackDocs opts pdbs
updater $ ms ^.. each . inspectedKey
scanPackageDbStack :: UpdateMonad m => [String] -> PackageDbStack -> m ()
scanPackageDbStack opts pdbs = runTask "scanning" pdbs $ Log.scope "package-db-stack" $ do
pdbStates <- liftIO $ mapM readPackageDb (packageDbs pdbs)
let
packageDbMods = S.fromList $ concat $ concatMap M.elems pdbStates
packages' = ordNub $ concatMap M.keys pdbStates
Log.sendLog Log.Trace $ "package-db-stack state: {} modules" ~~ length packageDbMods
watch (\w -> watchPackageDbStack w pdbs opts)
pkgs <- liftM concat $ forM (packageDbs pdbs) $ \pdb -> SQLite.query "select package_name, package_version from package_dbs where package_db == ?;" (SQLite.Only pdb)
if S.fromList packages' == S.fromList pkgs
then Log.sendLog Log.Trace "nothing changes, all packages the same"
else do
mlocs <- liftM
(filter (`S.member` packageDbMods)) $
(inSessionGhc $ listModules opts pdbs packages')
let
umlocs = uniqueModuleLocations mlocs
Log.sendLog Log.Trace $ "{} modules found, {} unique" ~~ length mlocs ~~ length umlocs
let
packageDbStackMods = liftM concat $ forM (packageDbs pdbs) $ \pdb -> SQLite.query "select m.id, m.file, m.cabal, m.install_dirs, m.package_name, m.package_version, m.installed_name, m.exposed, m.other_location, m.inspection_time, m.inspection_opts from modules as m, package_dbs as ps where m.package_name == ps.package_name and m.package_version == ps.package_version and ps.package_db == ?;" (SQLite.Only pdb)
scan packageDbStackMods ((,,) <$> umlocs <*> pure [] <*> pure Nothing) opts $ \mlocs' -> do
ms <- inSessionGhc $ browseModules opts pdbs (mlocs' ^.. each . _1)
Log.sendLog Log.Trace $ "scanned {} modules" ~~ length ms
sendUpdateAction $ timer "updated package-db-stack modules" $ do
SQLite.updateModules ms
sequence_ [SQLite.updatePackageDb pdb (M.keys pdbState) | (pdb, pdbState) <- zip (packageDbs pdbs) pdbStates]
when hdocsSupported $ scanPackageDbStackDocs opts pdbs
updater $ ms ^.. each . inspectedKey
scanProjectFile :: UpdateMonad m => [String] -> BuildTool -> Path -> m Project
scanProjectFile opts tool cabal = runTask "scanning" cabal $ do
proj <- fmap (set projectBuildTool tool) $ S.scanProjectFile opts cabal
pdbs <- inSessionGhc $ getProjectPackageDbStack proj
let
proj' = set projectPackageDbStack (Just pdbs) proj
sendUpdateAction $ Log.scope "scan-project-file" $ SQLite.updateProject proj'
return proj'
refineProjectInfo :: UpdateMonad m => Project -> m Project
refineProjectInfo proj = do
[SQLite.Only exist] <- SQLite.query "select count(*) > 0 from projects where cabal == ?;" (SQLite.Only (proj ^. projectCabal))
if exist
then SQLite.loadProject (proj ^. projectCabal)
else runTask "scanning" (proj ^. projectCabal) $ do
proj' <- liftIO $ loadProject proj
pdbs <- inSessionGhc $ getProjectPackageDbStack proj'
let
proj'' = set projectPackageDbStack (Just pdbs) proj'
sendUpdateAction $ Log.scope "refine-project-info" $ SQLite.updateProject proj''
return proj''
locateProjectInfo :: UpdateMonad m => Path -> m (Maybe Project)
locateProjectInfo cabal = liftIO (locateProject (view path cabal)) >>= traverse refineProjectInfo
scanProjectStack :: UpdateMonad m => [String] -> BuildTool -> Path -> m ()
scanProjectStack opts tool cabal = do
sbox <- liftIO $ projectSandbox tool cabal
maybe (scanCabal opts) (scanSandbox opts) sbox
scanProject opts tool cabal
scanProject :: UpdateMonad m => [String] -> BuildTool -> Path -> m ()
scanProject opts tool cabal = runTask "scanning" (project $ view path cabal) $ Log.scope "project" $ do
proj <- scanProjectFile opts tool cabal
watch (\w -> watchProject w proj opts)
S.ScanContents _ [(_, sources)] _ <- S.enumProject proj
let
projMods = SQLite.query "select m.id, m.file, m.cabal, m.install_dirs, m.package_name, m.package_version, m.installed_name, m.exposed, m.other_location, m.inspection_time, m.inspection_opts from modules as m where m.file is not null and m.cabal == ?;" (SQLite.Only $ proj ^. projectCabal)
scan projMods sources opts $ scanModules opts
scanDirectory :: UpdateMonad m => [String] -> Path -> m ()
scanDirectory opts dir = runTask "scanning" dir $ Log.scope "directory" $ do
S.ScanContents standSrcs projSrcs pdbss <- S.enumDirectory (view path dir)
runTasks_ [scanProject opts CabalTool (view projectCabal p) | (p, _) <- projSrcs]
runTasks_ $ map (scanPackageDb opts) pdbss
mapMOf_ (each . _1) (watch . flip watchModule) standSrcs
let
standaloneMods = SQLite.query "select m.id, m.file, m.cabal, m.install_dirs, m.package_name, m.package_version, m.installed_name, m.exposed, m.other_location, m.inspection_time, m.inspection_opts from modules as m where m.cabal is null and m.file is not null and m.file like ? escape '\\';" (SQLite.Only $ SQLite.escapeLike dir `T.append` "%")
scan standaloneMods standSrcs opts $ scanModules opts
scanPackageDbStackDocs :: UpdateMonad m => [String] -> PackageDbStack -> m ()
scanPackageDbStackDocs opts pdbs
| hdocsSupported = Log.scope "docs" $ do
docs <- inSessionGhc $ hdocsCabal pdbs opts
Log.sendLog Log.Trace $ "docs scanned: {} packages, {} modules total"
~~ length docs ~~ sum (map (M.size . snd) docs)
sendUpdateAction $ transact $ SQLite.executeMany "update symbols set docs = ? where name == ? and module_id in (select id from modules where name == ? and package_name == ? and package_version == ?);" $ do
(ModulePackage pname pver, pdocs) <- docs
(mname, mdocs) <- M.toList pdocs
(nm, doc) <- M.toList mdocs
return (doc, nm, mname, pname, pver)
Log.sendLog Log.Trace "docs set"
| otherwise = Log.sendLog Log.Warning "hdocs not supported"
scanDocs :: UpdateMonad m => [Module] -> m ()
scanDocs
| hdocsSupported = runTasks_ . map scanDocs'
| otherwise = const $ Log.sendLog Log.Warning "hdocs not supported"
where
scanDocs' m = runTask "scanning docs" (view (moduleId . moduleLocation) m) $ Log.scope "docs" $ do
mid <- SQLite.lookupModule (m ^. moduleId)
mid' <- maybe (hsdevError $ SQLiteError "module id not found") return mid
m' <- mapMOf (moduleId . moduleLocation . moduleProject . _Just) refineProjectInfo m
Log.sendLog Log.Trace $ "Scanning docs for {}" ~~ view (moduleId . moduleLocation) m'
docsMap <- inSessionGhc $ do
(pdbs, opts') <- getModuleOpts [] m'
currentSession >>= maybe (return ()) (const clearTargets)
haddockSession pdbs opts'
readModuleDocs opts' m'
sendUpdateAction $ transact $ do
SQLite.executeMany "update symbols set docs = ? where name == ? and module_id == ?;"
[(doc, nm, mid') | (nm, doc) <- maybe [] M.toList docsMap]
SQLite.execute "update modules set tags = json_set(tags, '$.docs', 1) where id == ?;" (SQLite.Only mid')
setModTypes :: UpdateMonad m => ModuleId -> [Note TypedExpr] -> m ()
setModTypes m ts = Log.scope "set-types" $ do
mid <- SQLite.lookupModule m
mid' <- maybe (hsdevError $ SQLiteError "module id not found") return mid
sendUpdateAction $ transact $ do
SQLite.execute "delete from types where module_id = ?;" (SQLite.Only mid')
SQLite.executeMany "insert into types (module_id, line, column, line_to, column_to, expr, type) values (?, ?, ?, ?, ?, ?, ?);" [
(SQLite.Only mid' SQLite.:. view noteRegion n' SQLite.:. view note n') | n' <- uniqueBy (view noteRegion) ts]
SQLite.execute "update names set inferred_type = (select type from types as t where t.module_id = ? and names.line = t.line and names.column = t.column and names.line_to = t.line_to and names.column_to = t.column_to) where module_id == ?;"
(mid', mid')
SQLite.execute "update symbols set type = (select type from types as t where t.module_id = ? and symbols.line = t.line and symbols.column = t.column order by t.line_to, t.column_to) where module_id == ? and type is null;" (mid', mid')
SQLite.execute "update modules set tags = json_set(tags, '$.types', 1) where id == ?;" (SQLite.Only mid')
inferModTypes :: UpdateMonad m => [Module] -> m ()
inferModTypes = runTasks_ . map inferModTypes' where
inferModTypes' m = runTask "inferring types" (view (moduleId . moduleLocation) m) $ Log.scope "types" $ do
mid <- SQLite.lookupModule (m ^. moduleId)
_ <- maybe (hsdevError $ SQLiteError "module id not found") return mid
m' <- mapMOf (moduleId . moduleLocation . moduleProject . _Just) refineProjectInfo m
Log.sendLog Log.Trace $ "Inferring types for {}" ~~ view (moduleId . moduleLocation) m'
sess <- getSession
mcts <- fmap (fmap snd) $ S.getFileContents (m' ^?! moduleId . moduleLocation . moduleFile)
types' <- inSessionGhc $ do
targetSession [] m'
cacheGhcWarnings sess (m' ^.. moduleId . moduleLocation) $
fileTypes m' mcts
setModTypes (m' ^. moduleId) types'
scan :: UpdateMonad m
=> m [SQLite.Only Int SQLite.:. ModuleLocation SQLite.:. Inspection]
-> [S.ModuleToScan]
-> [String]
-> ([S.ModuleToScan] -> m ())
-> m ()
scan part' mlocs opts act = Log.scope "scan" $ do
mlocs' <- liftM (M.fromList . map (\(SQLite.Only mid SQLite.:. (m SQLite.:. i)) -> (m, (mid, i)))) part'
let
obsolete = M.filterWithKey (\k _ -> k `S.notMember` S.fromList (map (^. _1) mlocs)) mlocs'
changed <- S.changedModules (M.map snd mlocs') opts mlocs
sendUpdateAction $ Log.scope "remove-obsolete" $ transact $
forM_ (M.elems obsolete) $ SQLite.removeModule . fst
act changed
processEvents :: ([(Watched, Event)] -> IO ()) -> MVar (A.Async ()) -> MVar [(Watched, Event)] -> [(Watched, Event)] -> ClientM IO ()
processEvents handleEvents updaterTask eventsVar evs = Log.scope "event" $ do
Log.sendLog Log.Trace $ "events received: {}" ~~ intercalate ", " (evs ^.. each . _2 . eventPath)
l <- Log.askLog
liftIO $ do
modifyMVar_ eventsVar (return . (++evs))
modifyMVar_ updaterTask $ \task -> do
done <- fmap isJust $ poll task
if done
then do
Log.withLog l $ Log.sendLog Log.Trace "starting update thread"
A.async $ fix $ \loop -> do
updates <- modifyMVar eventsVar (\es -> return ([], es))
unless (null updates) $ handleEvents updates >> loop
else return task
updateEvents :: ServerMonadBase m => [(Watched, Event)] -> UpdateM m ()
updateEvents updates = Log.scope "updater" $ do
Log.sendLog Log.Trace $ "prepared to process {} events" ~~ length updates
files <- fmap concat $ forM updates $ \(w, e) -> case w of
WatchedProject proj projOpts
| isSource e -> do
Log.sendLog Log.Info $ "File '{file}' in project {proj} changed"
~~ ("file" ~% view eventPath e)
~~ ("proj" ~% view projectName proj)
[SQLite.Only mopts] <- SQLite.query "select inspection_opts from modules where file == ?;" (SQLite.Only $ view eventPath e)
opts <- maybe (return []) (maybe (parseErr' mopts) return . fromJSON') mopts
return [(FileSource (fromFilePath $ view eventPath e) Nothing, opts)]
| isCabal e -> do
Log.sendLog Log.Info $ "Project {proj} changed"
~~ ("proj" ~% view projectName proj)
scanProject projOpts (view projectBuildTool proj) (view projectCabal proj)
return []
| otherwise -> return []
WatchedPackageDb pdbs opts
| isConf e -> do
Log.sendLog Log.Info $ "Package db {package} changed"
~~ ("package" ~% topPackageDb pdbs)
scanPackageDb opts pdbs
return []
| otherwise -> return []
WatchedModule
| isSource e -> do
Log.sendLog Log.Info $ "Module {file} changed"
~~ ("file" ~% view eventPath e)
[SQLite.Only mopts] <- SQLite.query "select inspection_opts from modules where file == ?;" (SQLite.Only $ view eventPath e)
opts <- maybe (return []) (maybe (parseErr' mopts) return . fromJSON') mopts
return [(FileSource (fromFilePath $ view eventPath e) Nothing, opts)]
| otherwise -> return []
scanFiles files
where
parseErr' mopts' = do
Log.sendLog Log.Error $ "Error parsing inspection_opts: {}" ~~ show mopts'
hsdevError $ SQLiteError $ "Error parsing inspection_opts: {}" ~~ show mopts'
applyUpdates :: UpdateOptions -> [(Watched, Event)] -> ClientM IO ()
applyUpdates uopts = runUpdate uopts . updateEvents
cacheGhcWarnings :: Session -> [ModuleLocation] -> GhcM a -> GhcM a
cacheGhcWarnings sess mlocs act = Log.scope "cache-warnings" $ do
tm <- liftIO getPOSIXTime
(r, msgs) <- collectMessages act
Log.sendLog Log.Trace $ "collected {} warnings" ~~ length msgs
_ <- liftIO $ withSession sess $ postSessionUpdater $ refreshCache mlocs tm msgs
return r
where
refreshCache :: [ModuleLocation] -> POSIXTime -> [Note OutputMessage] -> ServerM IO ()
refreshCache mlocs' tm' msgs' = Log.scope "refresh" $ bracket_ initTemp dropTemp $ do
fillTemp
removeOutdated
insertMessages
where
initTemp :: SessionMonad m => m ()
initTemp = do
SQLite.execute_ "create temporary table updating_files (file text not null, mtime real not null);"
SQLite.execute_ "create index updating_files_index on updating_files (file);"
SQLite.execute_ "create temporary table updating_ids (id integer not null unique, mtime real);"
SQLite.execute_ "create temporary table updating_messages as select * from messages where 0;"
SQLite.execute_ "create index update_messages_module_id_index on updating_messages (module_id);"
dropTemp :: SessionMonad m => m ()
dropTemp = do
SQLite.execute_ "drop table if exists updating_files;"
SQLite.execute_ "drop table if exists updating_ids;"
SQLite.execute_ "drop table if exists updating_messages;"
fillTemp :: SessionMonad m => m ()
fillTemp = do
mtimes <- forM (mlocs' ^.. each . moduleFile) $ \file' -> (,) <$> pure file' <*> liftIO (fileMTime file')
SQLite.executeMany "insert into updating_files values (?, ?);" mtimes
SQLite.execute_ "update updating_files set mtime = coalesce(max(mtime, (select c.mtime from file_contents as c where c.file == updating_files.file)), mtime);"
SQLite.execute_ "insert into updating_ids select distinct m.id, coalesce(max(u.mtime, m.inspection_time), u.mtime) from modules as m, updating_files as u where m.file = u.file;"
SQLite.executeMany "insert into updating_messages select (select m.id from modules as m where (m.file = ?)), ?, ?, ?, ?, ?, ?, ?;" msgs'
SQLite.execute_ "insert into updating_ids select distinct umsgs.module_id, m.inspection_time from updating_messages as umsgs, modules as m where umsgs.module_id = m.id and umsgs.module_id not in (select id from updating_ids);"
removeOutdated :: SessionMonad m => m ()
removeOutdated = SQLite.execute_ $ fromString $ unlines [
"delete from messages",
"where",
" module_id in (",
" select um.id",
" from updating_ids as um",
" left outer join load_times as lt",
" on lt.module_id = um.id",
" where",
" lt.load_time is null or",
" lt.load_time <= um.mtime or",
" um.id in (select distinct umsgs.module_id from updating_messages as umsgs)",
" );"]
insertMessages :: SessionMonad m => m ()
insertMessages = SQLite.transaction_ SQLite.Deferred $ do
SQLite.execute "insert or replace into load_times (module_id, load_time) select um.id, ? from updating_ids as um;" (SQLite.Only tm')
SQLite.execute_ "insert into messages select distinct * from updating_messages;"
cachedWarnings :: SessionMonad m => [ModuleLocation] -> m [Note OutputMessage]
cachedWarnings mlocs = liftM concat $ forM (mlocs ^.. each . moduleFile) $ \f -> SQLite.query @_ @(Note OutputMessage) (SQLite.toQuery $ mconcat [
SQLite.qNote "m" "n",
SQLite.from_ ["load_times as lt"],
SQLite.where_ [
"lt.module_id = m.id",
"m.file = ?",
"lt.load_time >= m.inspection_time"]])
(SQLite.Only f)
watch :: SessionMonad m => (Watcher -> IO ()) -> m ()
watch f = whenJustM (askSession sessionWatcher) $ liftIO . f