module HsDev.Database.Update (
Status(..), Progress(..), Task(..),
UpdateOptions(..),
UpdateM(..),
runUpdate,
postStatus, updater, runTask, runTasks, runTasks_,
scanModules, scanFile, scanFiles, scanFileContents, scanCabal, prepareSandbox, scanSandbox, scanPackageDb, scanProjectFile, scanProjectStack, scanProject, scanDirectory, scanContents,
scanPackageDbStackDocs, scanDocs,
setModTypes, inferModTypes,
scan,
processEvents, updateEvents, applyUpdates,
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 hiding ((.=))
import Control.Monad.Catch (catch, handle, MonadThrow)
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.Writer
import Control.Monad.State (get, modify, evalStateT)
import Data.Aeson
import Data.List (intercalate)
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import System.FilePath
import qualified System.Log.Simple as Log
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 (wait, 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')
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:))
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
scanModules :: UpdateMonad m => [String] -> [S.ModuleToScan] -> m ()
scanModules opts ms = Log.scope "scan-modules" $ mapM_ (uncurry scanModules') grouped where
scanModules' mproj ms' = do
pdbs <- maybe (return userDb) (inSessionGhc . getProjectPackageDbStack) mproj
case mproj of
Just proj -> sendUpdateAction $ SQLite.updateProject proj (Just pdbs)
Nothing -> return ()
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
case (mfcts ^? _Just . _1) of
Just tm -> Log.sendLog Log.Trace $ "using edited file contents, mtime = {}" ~~ show tm
Nothing -> return ()
let
resetInspection = maybe id (set preloadedTime . fileContentsInspection_ (opts ++ mopts)) $ mfcts ^? _Just . _1
mcts' = mplus mcts (mfcts ^? _Just . _2)
p <- liftIO $ preload (mloc ^?! moduleFile) defines (opts ++ mopts) mloc mcts'
return $ resetInspection p
ploaded <- runTasks (map pload ms')
mlocs' <- forM ploaded $ \p -> do
let
mloc = p ^. preloadedId . moduleLocation
inspectedMod = Inspected (p ^. preloadedTime) mloc (tag OnlyHeaderTag) $ Right $ p ^. asModule
sendUpdateAction $ Log.scope "preloaded" $ SQLite.updateModule inspectedMod
return mloc
updater mlocs'
(sqlMods', sqlAenv') <- do
let
mprojectDeps = SQLite.buildQuery $ SQLite.select_
["ps.module_id"]
["projects_modules_scope as ps"]
["ps.cabal is ?"]
sqlMods' <- SQLite.loadModules mprojectDeps (SQLite.Only $ mproj ^? _Just . projectCabal)
return (sqlMods', mconcat (map moduleAnalyzeEnv sqlMods'))
Log.sendLog Log.Trace $ "resolving environment: {} modules" ~~ length sqlMods'
case order ploaded of
Left err -> Log.sendLog Log.Error ("failed order dependencies for files: {}" ~~ show err)
Right ordered -> do
ms'' <- flip evalStateT sqlAenv' $ runTasks (map inspect' ordered)
mlocs'' <- forM ms'' $ \im -> do
sendUpdateAction $ Log.scope "resolved" $ SQLite.updateModule im
return $ im ^. inspectedKey
updater mlocs''
where
inspect' pmod = runTask "scanning" (pmod ^. preloadedId . moduleLocation) $ Log.scope "module" $ do
aenv <- get
m <- either (hsdevError . InspectError) eval $ analyzePreloaded aenv pmod
modify (mappend (moduleAnalyzeEnv m))
return $ Inspected (pmod ^. preloadedTime) (m ^. moduleId . moduleLocation) mempty (Right m)
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 -> m ()
scanFile opts fpath = scanFiles [(FileSource fpath Nothing, opts)]
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.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) (map (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 StackWork fpath) = Log.scope "prepare" $ runTasks_ [
runTask "building dependencies" sbox $ void $ Util.withCurrentDirectory dir $ inSessionGhc $ S.buildDeps Nothing,
runTask "configuring" sbox $ void $ Util.withCurrentDirectory dir $ inSessionGhc $ S.configure Nothing]
where
dir = takeDirectory $ view path fpath
prepareSandbox _ = return ()
scanSandbox :: UpdateMonad m => [String] -> Sandbox -> m ()
scanSandbox opts sbox = Log.scope "sandbox" $ do
prepareSandbox sbox
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')
Log.sendLog Log.Trace $ "{} modules found" ~~ length mlocs
let
packageDbMods' = SQLite.query "select m.id, m.file, m.cabal, m.install_dirs, m.package_name, m.package_version, m.installed_name, 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' ((,,) <$> mlocs <*> pure [] <*> pure Nothing) opts $ \mlocs' -> do
ms <- inSessionGhc $ browseModules opts pdbs (mlocs' ^.. each . _1)
Log.sendLog Log.Trace $ "scanned {} modules" ~~ length ms
sendUpdateAction $ do
mapM_ SQLite.updateModule 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')
Log.sendLog Log.Trace $ "{} modules found" ~~ length mlocs
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.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 ((,,) <$> mlocs <*> pure [] <*> pure Nothing) opts $ \mlocs' -> do
ms <- inSessionGhc $ browseModules opts pdbs (mlocs' ^.. each . _1)
Log.sendLog Log.Trace $ "scanned {} modules" ~~ length ms
sendUpdateAction $ do
mapM_ SQLite.updateModule 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] -> Path -> m Project
scanProjectFile opts cabal = runTask "scanning" cabal $ do
proj <- S.scanProjectFile opts cabal
pdbs <- inSessionGhc $ getProjectPackageDbStack proj
sendUpdateAction $ Log.scope "scan-project-file" $ SQLite.updateProject proj (Just pdbs)
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'
sendUpdateAction $ Log.scope "refine-project-info" $ SQLite.updateProject proj' (Just pdbs)
return proj'
locateProjectInfo :: UpdateMonad m => Path -> m (Maybe Project)
locateProjectInfo cabal = liftIO (locateProject (view path cabal)) >>= traverse refineProjectInfo
scanProjectStack :: UpdateMonad m => [String] -> Path -> m ()
scanProjectStack opts cabal = do
proj <- scanProjectFile opts cabal
scanProject opts cabal
sbox <- liftIO $ projectSandbox (view projectPath proj)
maybe (scanCabal opts) (scanSandbox opts) sbox
scanProject :: UpdateMonad m => [String] -> Path -> m ()
scanProject opts cabal = runTask "scanning" (project $ view path cabal) $ Log.scope "project" $ do
proj <- scanProjectFile opts 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.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 $ \mlocs' -> do
scanModules opts mlocs'
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 (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.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
scanContents :: UpdateMonad m => [String] -> S.ScanContents -> m ()
scanContents opts (S.ScanContents standSrcs projSrcs pdbss) = do
projs <- liftM (map SQLite.fromOnly) $ SQLite.query_ "select cabal from projects;"
pdbs <- liftM (map SQLite.fromOnly) $ SQLite.query_ "select package_db from package_dbs;"
let
filesMods = SQLite.query_ "select m.id, m.file, m.cabal, m.install_dirs, m.package_name, m.package_version, m.installed_name, m.other_location, m.inspection_time, m.inspection_opts from modules as m where m.file is not null and m.cabal is null;"
runTasks_ [scanPackageDb opts pdbs' | pdbs' <- pdbss, topPackageDb pdbs' `notElem` pdbs]
runTasks_ [scanProject opts (view projectCabal p) | (p, _) <- projSrcs, view projectCabal p `notElem` projs]
mapMOf_ (each . _1) (watch . flip watchModule) standSrcs
scan filesMods 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 $ 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 $ 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 $ do
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' <- 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 == ?;" (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'
mcts <- fmap (fmap snd) $ S.getFileContents (m' ^?! moduleId . moduleLocation . moduleFile)
types' <- inSessionGhc $ do
targetSession [] m'
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" $ 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 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
watch :: SessionMonad m => (Watcher -> IO ()) -> m ()
watch f = do
w <- askSession sessionWatcher
liftIO $ f w