{-# 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 :: m ()
onStatus = (UpdateState -> [Task]) -> m [Task]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Getting [Task] UpdateState [Task] -> UpdateState -> [Task]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((UpdateOptions -> Const [Task] UpdateOptions)
-> UpdateState -> Const [Task] UpdateState
Lens' UpdateState UpdateOptions
updateOptions ((UpdateOptions -> Const [Task] UpdateOptions)
 -> UpdateState -> Const [Task] UpdateState)
-> (([Task] -> Const [Task] [Task])
    -> UpdateOptions -> Const [Task] UpdateOptions)
-> Getting [Task] UpdateState [Task]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Task] -> Const [Task] [Task])
-> UpdateOptions -> Const [Task] UpdateOptions
Lens' UpdateOptions [Task]
updateTasks)) m [Task] -> ([Task] -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Notification -> m ()
forall (m :: * -> *). CommandMonad m => Notification -> m ()
commandNotify (Notification -> m ())
-> ([Task] -> Notification) -> [Task] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Notification
Notification (Value -> Notification)
-> ([Task] -> Value) -> [Task] -> Notification
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Task] -> Value
forall a. ToJSON a => a -> Value
toJSON ([Task] -> Value) -> ([Task] -> [Task]) -> [Task] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Task] -> [Task]
forall a. [a] -> [a]
reverse

childTask :: UpdateMonad m => Task -> m a -> m a
childTask :: Task -> m a -> m a
childTask Task
t = (UpdateState -> UpdateState) -> m a -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ASetter UpdateState UpdateState [Task] [Task]
-> ([Task] -> [Task]) -> UpdateState -> UpdateState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((UpdateOptions -> Identity UpdateOptions)
-> UpdateState -> Identity UpdateState
Lens' UpdateState UpdateOptions
updateOptions ((UpdateOptions -> Identity UpdateOptions)
 -> UpdateState -> Identity UpdateState)
-> (([Task] -> Identity [Task])
    -> UpdateOptions -> Identity UpdateOptions)
-> ASetter UpdateState UpdateState [Task] [Task]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Task] -> Identity [Task])
-> UpdateOptions -> Identity UpdateOptions
Lens' UpdateOptions [Task]
updateTasks) (Task
tTask -> [Task] -> [Task]
forall a. a -> [a] -> [a]
:))

transact :: SessionMonad m => m a -> m a
transact :: m a -> m a
transact = TransactionType -> m a -> m a
forall (m :: * -> *) a.
SessionMonad m =>
TransactionType -> m a -> m a
SQLite.transaction_ TransactionType
SQLite.Immediate

runUpdate :: ServerMonadBase m => UpdateOptions -> UpdateM m a -> ClientM m a
runUpdate :: UpdateOptions -> UpdateM m a -> ClientM m a
runUpdate UpdateOptions
uopts UpdateM m a
act = Text -> ClientM m a -> ClientM m a
forall (m :: * -> *) a.
(MonadLog m, HasCallStack) =>
Text -> m a -> m a
Log.scope Text
"update" (ClientM m a -> ClientM m a) -> ClientM m a -> ClientM m a
forall a b. (a -> b) -> a -> b
$ do
	(a
r, [ModuleLocation]
updatedMods) <- UpdateOptions
-> (UpdateState -> ClientM m (a, [ModuleLocation]))
-> ClientM m (a, [ModuleLocation])
forall (m :: * -> *) a.
SessionMonad m =>
UpdateOptions -> (UpdateState -> m a) -> m a
withUpdateState UpdateOptions
uopts ((UpdateState -> ClientM m (a, [ModuleLocation]))
 -> ClientM m (a, [ModuleLocation]))
-> (UpdateState -> ClientM m (a, [ModuleLocation]))
-> ClientM m (a, [ModuleLocation])
forall a b. (a -> b) -> a -> b
$ \UpdateState
ust ->
		WriterT [ModuleLocation] (ClientM m) a
-> ClientM m (a, [ModuleLocation])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (UpdateM m a
-> ReaderT UpdateState (WriterT [ModuleLocation] (ClientM m)) a
forall (m :: * -> *) a.
UpdateM m a
-> ReaderT UpdateState (WriterT [ModuleLocation] (ClientM m)) a
runUpdateM UpdateM m a
act' ReaderT UpdateState (WriterT [ModuleLocation] (ClientM m)) a
-> UpdateState -> WriterT [ModuleLocation] (ClientM m) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` UpdateState
ust)
	Level -> Text -> ClientM m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Debug (Text -> ClientM m ()) -> Text -> ClientM m ()
forall a b. (a -> b) -> a -> b
$ Format
"updated {} modules" Format -> Int -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ [ModuleLocation] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ModuleLocation]
updatedMods
	a -> ClientM m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r
	where
		act' :: UpdateM m a
act' = do
			(a
r, [ModuleLocation]
_) <- UpdateM m a -> UpdateM m (a, [ModuleLocation])
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen UpdateM m a
act
			-- (r, mlocs') <- listen act

			-- dbs <- liftM S.unions $ forM mlocs' $ \mloc' -> do
			-- 	mid <- SQLite.lookupModuleLocation mloc'
			-- 	case mid of
			-- 		Nothing -> return (S.empty :: S.Set PackageDb)
			-- 		Just mid' -> liftM (S.fromList . map SQLite.fromOnly) $ SQLite.query (SQLite.toQuery $ SQLite.select_
			-- 			["ps.package_db"]
			-- 			["package_dbs as ps", "modules as m"]
			-- 			["m.package_name == ps.package_name", "m.package_version == ps.package_version", "m.id == ?"]) (SQLite.Only mid')

			-- If some sourced files depends on currently scanned package-dbs
			-- We must resolve them and even rescan if there was errors scanning without
			-- dependencies provided (lack of fixities can cause errors inspecting files)

			-- sboxes = databaseSandboxes dbval
			-- sboxOf :: Path -> Maybe Sandbox
			-- sboxOf fpath = find (pathInSandbox fpath) sboxes
			-- projsRows <- SQLite.query_ "select name, cabal, version, ifnull(package_db_stack, json('[]')) from projects;"
			-- let
			-- 	projs = [proj' | (proj' SQLite.:. (SQLite.Only (SQLite.JSON projPdbs))) <- projsRows,
			-- 		not (S.null (S.fromList projPdbs `S.intersection` dbs))]

			-- 	stands = []
			-- 	-- HOWTO?
			-- 	-- stands = do
			-- 	-- 	sloc <- dbval ^.. standaloneSlice . modules . moduleId . moduleLocation
			-- 	-- 	guard $ sboxUpdated $ sboxOf (sloc ^?! moduleFile)
			-- 	-- 	guard (notElem sloc mlocs')
			-- 	-- 	return (sloc, dbval ^.. databaseModules . ix sloc . inspection . inspectionOpts . each . unpacked, Nothing)

			-- Log.sendLog Log.Trace $ "updated package-dbs: {}, have to rescan {} projects and {} files"
			-- 	~~ intercalate ", " (map display $ S.toList dbs)
			-- 	~~ length projs ~~ length stands
			-- (_, rlocs') <- listen $ runTasks_ (scanModules [] stands : [scanProject [] (proj ^. projectCabal) | proj <- projs])
			-- let
			-- 	ulocs' = filter (isJust . preview moduleFile) (ordNub $ mlocs' ++ rlocs')
			-- 	getMods :: (MonadIO m) => m [InspectedModule]
			-- 	getMods = do
			-- 		db' <- liftIO $ readAsync db
			-- 		return $ filter ((`elem` ulocs') . view inspectedKey) $ toList $ view databaseModules db'

			-- FIXME: Now it's broken since `Database` is not used anymore
			Bool -> UpdateM m () -> UpdateM m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Getting Bool UpdateOptions Bool -> UpdateOptions -> Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Bool UpdateOptions Bool
Lens' UpdateOptions Bool
updateDocs UpdateOptions
uopts) (UpdateM m () -> UpdateM m ()) -> UpdateM m () -> UpdateM m ()
forall a b. (a -> b) -> a -> b
$ do
				Level -> Text -> UpdateM m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace Text
"forking inspecting source docs"
				Level -> Text -> UpdateM m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Warning Text
"not implemented"
				-- void $ fork (getMods >>= waiter . mapM_ scanDocs_)
			Bool -> UpdateM m () -> UpdateM m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Getting Bool UpdateOptions Bool -> UpdateOptions -> Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Bool UpdateOptions Bool
Lens' UpdateOptions Bool
updateInfer UpdateOptions
uopts) (UpdateM m () -> UpdateM m ()) -> UpdateM m () -> UpdateM m ()
forall a b. (a -> b) -> a -> b
$ do
				Level -> Text -> UpdateM m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace Text
"forking inferring types"
				Level -> Text -> UpdateM m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Warning Text
"not implemented"
				-- void $ fork (getMods >>= waiter . mapM_ inferModTypes_)
			a -> UpdateM m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r
		-- scanDocs_ :: UpdateMonad m => InspectedModule -> m ()
		-- scanDocs_ im = do
		-- 	im' <- (S.scanModify (\opts -> inSessionGhc . liftGhc . inspectDocsGhc opts) im) <|> return im
		-- 	sendUpdateAction $ Log.scope "scan-docs" $ SQLite.updateModule im'
		-- inferModTypes_ :: UpdateMonad m => InspectedModule -> m ()
		-- inferModTypes_ im = do
		-- 	-- TODO: locate sandbox
		-- 	im' <- (S.scanModify infer' im) <|> return im
		-- 	sendUpdateAction $ Log.scope "infer-types" $ SQLite.updateModule im'
		-- infer' :: UpdateMonad m => [String] -> Module -> m Module
		-- infer' opts m = case preview (moduleId . moduleLocation . moduleFile) m of
		-- 	Nothing -> return m
		-- 	Just _ -> inSessionGhc $ do
		-- 		targetSession opts m
		-- 		inferTypes opts m Nothing

-- | Post status
postStatus :: UpdateMonad m => Task -> m ()
postStatus :: Task -> m ()
postStatus Task
t = Task -> m () -> m ()
forall (m :: * -> *) a. UpdateMonad m => Task -> m a -> m a
childTask Task
t m ()
forall (m :: * -> *). UpdateMonad m => m ()
onStatus

-- | Mark module as updated
updater :: UpdateMonad m => [ModuleLocation] -> m ()
updater :: [ModuleLocation] -> m ()
updater [ModuleLocation]
mlocs = [ModuleLocation] -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell ([ModuleLocation] -> m ()) -> [ModuleLocation] -> m ()
forall a b. NFData a => (a -> b) -> a -> b
$!! [ModuleLocation]
mlocs

-- | Run one task
runTask :: (Display t, UpdateMonad m, NFData a) => String -> t -> m a -> m a
runTask :: String -> t -> m a -> m a
runTask String
action t
subj m a
act = Text -> m a -> m a
forall (m :: * -> *) a.
(MonadLog m, HasCallStack) =>
Text -> m a -> m a
Log.scope Text
"task" (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ do
	Task -> m ()
forall (m :: * -> *). UpdateMonad m => Task -> m ()
postStatus (Task -> m ()) -> Task -> m ()
forall a b. (a -> b) -> a -> b
$ ASetter Task Task Status Status -> Status -> Task -> Task
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Task Task Status Status
Lens' Task Status
taskStatus Status
StatusWorking Task
task
	a
x <- Task -> m a -> m a
forall (m :: * -> *) a. UpdateMonad m => Task -> m a -> m a
childTask Task
task m a
act
	a
x a -> m () -> m ()
forall a b. NFData a => a -> b -> b
`deepseq` Task -> m ()
forall (m :: * -> *). UpdateMonad m => Task -> m ()
postStatus (ASetter Task Task Status Status -> Status -> Task -> Task
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Task Task Status Status
Lens' Task Status
taskStatus Status
StatusOk Task
task)
	a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
	m a -> (HsDevError -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch`
	(\HsDevError
e -> Task -> m ()
forall (m :: * -> *). UpdateMonad m => Task -> m ()
postStatus (ASetter Task Task Status Status -> Status -> Task -> Task
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Task Task Status Status
Lens' Task Status
taskStatus (HsDevError -> Status
StatusError HsDevError
e) Task
task) m () -> m a -> m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> HsDevError -> m a
forall (m :: * -> *) a. MonadThrow m => HsDevError -> m a
hsdevError HsDevError
e)
	where
		task :: Task
task = Task :: String -> Status -> String -> String -> Maybe Progress -> Task
Task {
			_taskName :: String
_taskName = String
action,
			_taskStatus :: Status
_taskStatus = Status
StatusWorking,
			_taskSubjectType :: String
_taskSubjectType = t -> String
forall a. Display a => a -> String
displayType t
subj,
			_taskSubjectName :: String
_taskSubjectName = t -> String
forall a. Display a => a -> String
display t
subj,
			_taskProgress :: Maybe Progress
_taskProgress = Maybe Progress
forall a. Maybe a
Nothing }

-- | Run many tasks with numeration
runTasks :: UpdateMonad m => [m a] -> m [a]
runTasks :: [m a] -> m [a]
runTasks [m a]
ts = ([Maybe a] -> [a]) -> m [Maybe a] -> m [a]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Maybe a] -> [a]
forall a. [Maybe a] -> [a]
catMaybes (m [Maybe a] -> m [a]) -> m [Maybe a] -> m [a]
forall a b. (a -> b) -> a -> b
$ (Int -> m (Maybe a) -> m (Maybe a))
-> [Int] -> [m (Maybe a)] -> m [Maybe a]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Int -> m (Maybe a) -> m (Maybe a)
forall (m :: * -> *) a.
MonadReader UpdateState m =>
Int -> m a -> m a
taskNum [Int
1..] ((m a -> m (Maybe a)) -> [m a] -> [m (Maybe a)]
forall a b. (a -> b) -> [a] -> [b]
map m a -> m (Maybe a)
forall (m :: * -> *) a. MonadCatch m => m a -> m (Maybe a)
noErr [m a]
ts) where
	total :: Int
total = [m a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [m a]
ts
	taskNum :: Int -> m a -> m a
taskNum Int
n = (UpdateState -> UpdateState) -> m a -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local UpdateState -> UpdateState
setProgress where
		setProgress :: UpdateState -> UpdateState
setProgress = ASetter UpdateState UpdateState (Maybe Progress) (Maybe Progress)
-> Maybe Progress -> UpdateState -> UpdateState
forall s t a b. ASetter s t a b -> b -> s -> t
set ((UpdateOptions -> Identity UpdateOptions)
-> UpdateState -> Identity UpdateState
Lens' UpdateState UpdateOptions
updateOptions ((UpdateOptions -> Identity UpdateOptions)
 -> UpdateState -> Identity UpdateState)
-> ((Maybe Progress -> Identity (Maybe Progress))
    -> UpdateOptions -> Identity UpdateOptions)
-> ASetter
     UpdateState UpdateState (Maybe Progress) (Maybe Progress)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Task] -> Identity [Task])
-> UpdateOptions -> Identity UpdateOptions
Lens' UpdateOptions [Task]
updateTasks (([Task] -> Identity [Task])
 -> UpdateOptions -> Identity UpdateOptions)
-> ((Maybe Progress -> Identity (Maybe Progress))
    -> [Task] -> Identity [Task])
-> (Maybe Progress -> Identity (Maybe Progress))
-> UpdateOptions
-> Identity UpdateOptions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Task -> Identity Task) -> [Task] -> Identity [Task]
forall s a. Cons s s a a => Traversal' s a
_head ((Task -> Identity Task) -> [Task] -> Identity [Task])
-> ((Maybe Progress -> Identity (Maybe Progress))
    -> Task -> Identity Task)
-> (Maybe Progress -> Identity (Maybe Progress))
-> [Task]
-> Identity [Task]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Progress -> Identity (Maybe Progress))
-> Task -> Identity Task
Lens' Task (Maybe Progress)
taskProgress) (Progress -> Maybe Progress
forall a. a -> Maybe a
Just (Int -> Int -> Progress
Progress Int
n Int
total))
	noErr :: m a -> m (Maybe a)
noErr m a
v = Maybe a -> m (Maybe a) -> m (Maybe a)
forall (m :: * -> *) a. MonadCatch m => a -> m a -> m a
hsdevIgnore Maybe a
forall a. Maybe a
Nothing (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> m a -> m (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
v)

-- | Run many tasks with numeration
runTasks_ :: UpdateMonad m => [m ()] -> m ()
runTasks_ :: [m ()] -> m ()
runTasks_ = m [()] -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m [()] -> m ()) -> ([m ()] -> m [()]) -> [m ()] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [m ()] -> m [()]
forall (m :: * -> *) a. UpdateMonad m => [m a] -> m [a]
runTasks

data PreloadFailure = PreloadFailure ModuleLocation Inspection HsDevError

instance NFData PreloadFailure where
	rnf :: PreloadFailure -> ()
rnf (PreloadFailure ModuleLocation
mloc Inspection
insp HsDevError
err) = ModuleLocation -> ()
forall a. NFData a => a -> ()
rnf ModuleLocation
mloc () -> () -> ()
`seq` Inspection -> ()
forall a. NFData a => a -> ()
rnf Inspection
insp () -> () -> ()
`seq` HsDevError -> ()
forall a. NFData a => a -> ()
rnf HsDevError
err

-- | Scan modules
scanModules :: UpdateMonad m => [String] -> [S.ModuleToScan] -> m ()
scanModules :: [String] -> [ModuleToScan] -> m ()
scanModules [String]
opts [ModuleToScan]
ms = Text -> m () -> m ()
forall (m :: * -> *) a.
(MonadLog m, HasCallStack) =>
Text -> m a -> m a
Log.scope Text
"scan-modules" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ ((Maybe Project, [ModuleToScan]) -> m ())
-> [(Maybe Project, [ModuleToScan])] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Maybe Project -> [ModuleToScan] -> m ())
-> (Maybe Project, [ModuleToScan]) -> m ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Maybe Project -> [ModuleToScan] -> m ()
forall (m :: * -> *).
(CommandMonad m, MonadWriter [ModuleLocation] m,
 MonadReader UpdateState m) =>
Maybe Project -> [ModuleToScan] -> m ()
scanModules') [(Maybe Project, [ModuleToScan])]
grouped where
	scanModules' :: Maybe Project -> [ModuleToScan] -> m ()
scanModules' Maybe Project
mproj [ModuleToScan]
ms' = do
		m () -> (Project -> m ()) -> Maybe Project -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (ServerM IO () -> m ()
forall (m :: * -> *). UpdateMonad m => ServerM IO () -> m ()
sendUpdateAction (ServerM IO () -> m ())
-> (Project -> ServerM IO ()) -> Project -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Project -> ServerM IO ()
forall (m :: * -> *). SessionMonad m => Project -> m ()
SQLite.updateProject) Maybe Project
mproj
		[ModuleLocation] -> m ()
forall (m :: * -> *). UpdateMonad m => [ModuleLocation] -> m ()
updater ([ModuleLocation] -> m ()) -> [ModuleLocation] -> m ()
forall a b. (a -> b) -> a -> b
$ [ModuleToScan]
ms' [ModuleToScan]
-> Getting (Endo [ModuleLocation]) [ModuleToScan] ModuleLocation
-> [ModuleLocation]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. (ModuleToScan -> Const (Endo [ModuleLocation]) ModuleToScan)
-> [ModuleToScan] -> Const (Endo [ModuleLocation]) [ModuleToScan]
forall s t a b. Each s t a b => Traversal s t a b
each ((ModuleToScan -> Const (Endo [ModuleLocation]) ModuleToScan)
 -> [ModuleToScan] -> Const (Endo [ModuleLocation]) [ModuleToScan])
-> ((ModuleLocation
     -> Const (Endo [ModuleLocation]) ModuleLocation)
    -> ModuleToScan -> Const (Endo [ModuleLocation]) ModuleToScan)
-> Getting (Endo [ModuleLocation]) [ModuleToScan] ModuleLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleLocation -> Const (Endo [ModuleLocation]) ModuleLocation)
-> ModuleToScan -> Const (Endo [ModuleLocation]) ModuleToScan
forall s t a b. Field1 s t a b => Lens s t a b
_1
		[(String, String)]
defines <- (Session -> [(String, String)]) -> m [(String, String)]
forall (m :: * -> *) a. SessionMonad m => (Session -> a) -> m a
askSession Session -> [(String, String)]
sessionDefines

		let
			pload :: ModuleToScan -> m (Inspected ModuleLocation ModuleTag Preloaded)
pload (ModuleLocation
mloc, [String]
mopts, Maybe Text
mcts) = String
-> ModuleLocation
-> m (Inspected ModuleLocation ModuleTag Preloaded)
-> m (Inspected ModuleLocation ModuleTag Preloaded)
forall t (m :: * -> *) a.
(Display t, UpdateMonad m, NFData a) =>
String -> t -> m a -> m a
runTask String
"preloading" ModuleLocation
mloc (m (Inspected ModuleLocation ModuleTag Preloaded)
 -> m (Inspected ModuleLocation ModuleTag Preloaded))
-> m (Inspected ModuleLocation ModuleTag Preloaded)
-> m (Inspected ModuleLocation ModuleTag Preloaded)
forall a b. (a -> b) -> a -> b
$ do
				Maybe (POSIXTime, Text)
mfcts <- m (Maybe (POSIXTime, Text))
-> (Text -> m (Maybe (POSIXTime, Text)))
-> Maybe Text
-> m (Maybe (POSIXTime, Text))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> m (Maybe (POSIXTime, Text))
forall (m :: * -> *).
SessionMonad m =>
Text -> m (Maybe (POSIXTime, Text))
S.getFileContents (ModuleLocation
mloc ModuleLocation -> Getting (Endo Text) ModuleLocation Text -> Text
forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! Getting (Endo Text) ModuleLocation Text
Traversal' ModuleLocation Text
moduleFile)) (m (Maybe (POSIXTime, Text)) -> Text -> m (Maybe (POSIXTime, Text))
forall a b. a -> b -> a
const (m (Maybe (POSIXTime, Text))
 -> Text -> m (Maybe (POSIXTime, Text)))
-> m (Maybe (POSIXTime, Text))
-> Text
-> m (Maybe (POSIXTime, Text))
forall a b. (a -> b) -> a -> b
$ Maybe (POSIXTime, Text) -> m (Maybe (POSIXTime, Text))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (POSIXTime, Text)
forall a. Maybe a
Nothing) Maybe Text
mcts
				Inspection
insp <- IO Inspection -> m Inspection
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Inspection -> m Inspection) -> IO Inspection -> m Inspection
forall a b. (a -> b) -> a -> b
$ Text -> [String] -> IO Inspection
fileInspection (ModuleLocation
mloc ModuleLocation -> Getting (Endo Text) ModuleLocation Text -> Text
forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! Getting (Endo Text) ModuleLocation Text
Traversal' ModuleLocation Text
moduleFile) ([String]
opts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
mopts)
				case (Maybe (POSIXTime, Text)
mfcts Maybe (POSIXTime, Text)
-> Getting (First POSIXTime) (Maybe (POSIXTime, Text)) POSIXTime
-> Maybe POSIXTime
forall s a. s -> Getting (First a) s a -> Maybe a
^? ((POSIXTime, Text) -> Const (First POSIXTime) (POSIXTime, Text))
-> Maybe (POSIXTime, Text)
-> Const (First POSIXTime) (Maybe (POSIXTime, Text))
forall a b. Prism (Maybe a) (Maybe b) a b
_Just (((POSIXTime, Text) -> Const (First POSIXTime) (POSIXTime, Text))
 -> Maybe (POSIXTime, Text)
 -> Const (First POSIXTime) (Maybe (POSIXTime, Text)))
-> ((POSIXTime -> Const (First POSIXTime) POSIXTime)
    -> (POSIXTime, Text) -> Const (First POSIXTime) (POSIXTime, Text))
-> Getting (First POSIXTime) (Maybe (POSIXTime, Text)) POSIXTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (POSIXTime -> Const (First POSIXTime) POSIXTime)
-> (POSIXTime, Text) -> Const (First POSIXTime) (POSIXTime, Text)
forall s t a b. Field1 s t a b => Lens s t a b
_1) of
					Just POSIXTime
tm -> Level -> Text -> m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Format
"using edited file contents, mtime = {}" Format -> String -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ POSIXTime -> String
forall a. Show a => a -> String
show POSIXTime
tm
					Maybe POSIXTime
Nothing -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
				let
					inspection' :: Inspection
inspection' = Inspection
-> (POSIXTime -> Inspection) -> Maybe POSIXTime -> Inspection
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Inspection
insp ([String] -> POSIXTime -> Inspection
fileContentsInspection_ ([String]
opts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
mopts)) (Maybe POSIXTime -> Inspection) -> Maybe POSIXTime -> Inspection
forall a b. (a -> b) -> a -> b
$ Maybe (POSIXTime, Text)
mfcts Maybe (POSIXTime, Text)
-> Getting (First POSIXTime) (Maybe (POSIXTime, Text)) POSIXTime
-> Maybe POSIXTime
forall s a. s -> Getting (First a) s a -> Maybe a
^? ((POSIXTime, Text) -> Const (First POSIXTime) (POSIXTime, Text))
-> Maybe (POSIXTime, Text)
-> Const (First POSIXTime) (Maybe (POSIXTime, Text))
forall a b. Prism (Maybe a) (Maybe b) a b
_Just (((POSIXTime, Text) -> Const (First POSIXTime) (POSIXTime, Text))
 -> Maybe (POSIXTime, Text)
 -> Const (First POSIXTime) (Maybe (POSIXTime, Text)))
-> ((POSIXTime -> Const (First POSIXTime) POSIXTime)
    -> (POSIXTime, Text) -> Const (First POSIXTime) (POSIXTime, Text))
-> Getting (First POSIXTime) (Maybe (POSIXTime, Text)) POSIXTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (POSIXTime -> Const (First POSIXTime) POSIXTime)
-> (POSIXTime, Text) -> Const (First POSIXTime) (POSIXTime, Text)
forall s t a b. Field1 s t a b => Lens s t a b
_1
					dirtyTag' :: InspectM k ModuleTag m a -> InspectM k ModuleTag m a
dirtyTag' = (InspectM k ModuleTag m a -> InspectM k ModuleTag m a)
-> (POSIXTime
    -> InspectM k ModuleTag m a -> InspectM k ModuleTag m a)
-> Maybe POSIXTime
-> InspectM k ModuleTag m a
-> InspectM k ModuleTag m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe InspectM k ModuleTag m a -> InspectM k ModuleTag m a
forall a. a -> a
id ((InspectM k ModuleTag m a -> InspectM k ModuleTag m a)
-> POSIXTime
-> InspectM k ModuleTag m a
-> InspectM k ModuleTag m a
forall a b. a -> b -> a
const ((InspectM k ModuleTag m a -> InspectM k ModuleTag m a)
 -> POSIXTime
 -> InspectM k ModuleTag m a
 -> InspectM k ModuleTag m a)
-> (InspectM k ModuleTag m a -> InspectM k ModuleTag m a)
-> POSIXTime
-> InspectM k ModuleTag m a
-> InspectM k ModuleTag m a
forall a b. (a -> b) -> a -> b
$ ModuleTag -> InspectM k ModuleTag m a -> InspectM k ModuleTag m a
forall (m :: * -> *) t k a.
(Monad m, Ord t) =>
t -> InspectM k t m a -> InspectM k t m a
inspectTag ModuleTag
DirtyTag) (Maybe POSIXTime
 -> InspectM k ModuleTag m a -> InspectM k ModuleTag m a)
-> Maybe POSIXTime
-> InspectM k ModuleTag m a
-> InspectM k ModuleTag m a
forall a b. (a -> b) -> a -> b
$ Maybe (POSIXTime, Text)
mfcts Maybe (POSIXTime, Text)
-> Getting (First POSIXTime) (Maybe (POSIXTime, Text)) POSIXTime
-> Maybe POSIXTime
forall s a. s -> Getting (First a) s a -> Maybe a
^? ((POSIXTime, Text) -> Const (First POSIXTime) (POSIXTime, Text))
-> Maybe (POSIXTime, Text)
-> Const (First POSIXTime) (Maybe (POSIXTime, Text))
forall a b. Prism (Maybe a) (Maybe b) a b
_Just (((POSIXTime, Text) -> Const (First POSIXTime) (POSIXTime, Text))
 -> Maybe (POSIXTime, Text)
 -> Const (First POSIXTime) (Maybe (POSIXTime, Text)))
-> ((POSIXTime -> Const (First POSIXTime) POSIXTime)
    -> (POSIXTime, Text) -> Const (First POSIXTime) (POSIXTime, Text))
-> Getting (First POSIXTime) (Maybe (POSIXTime, Text)) POSIXTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (POSIXTime -> Const (First POSIXTime) POSIXTime)
-> (POSIXTime, Text) -> Const (First POSIXTime) (POSIXTime, Text)
forall s t a b. Field1 s t a b => Lens s t a b
_1
					mcts' :: Maybe Text
mcts' = Maybe Text -> Maybe Text -> Maybe Text
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus Maybe Text
mcts (Maybe (POSIXTime, Text)
mfcts Maybe (POSIXTime, Text)
-> Getting (First Text) (Maybe (POSIXTime, Text)) Text
-> Maybe Text
forall s a. s -> Getting (First a) s a -> Maybe a
^? ((POSIXTime, Text) -> Const (First Text) (POSIXTime, Text))
-> Maybe (POSIXTime, Text)
-> Const (First Text) (Maybe (POSIXTime, Text))
forall a b. Prism (Maybe a) (Maybe b) a b
_Just (((POSIXTime, Text) -> Const (First Text) (POSIXTime, Text))
 -> Maybe (POSIXTime, Text)
 -> Const (First Text) (Maybe (POSIXTime, Text)))
-> ((Text -> Const (First Text) Text)
    -> (POSIXTime, Text) -> Const (First Text) (POSIXTime, Text))
-> Getting (First Text) (Maybe (POSIXTime, Text)) Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const (First Text) Text)
-> (POSIXTime, Text) -> Const (First Text) (POSIXTime, Text)
forall s t a b. Field2 s t a b => Lens s t a b
_2)
				ModuleLocation
-> InspectM ModuleLocation ModuleTag m Preloaded
-> m (Inspected ModuleLocation ModuleTag Preloaded)
forall (m :: * -> *) t k a.
(Monad m, Ord t) =>
k -> InspectM k t m a -> m (Inspected k t a)
runInspect ModuleLocation
mloc (InspectM ModuleLocation ModuleTag m Preloaded
 -> m (Inspected ModuleLocation ModuleTag Preloaded))
-> InspectM ModuleLocation ModuleTag m Preloaded
-> m (Inspected ModuleLocation ModuleTag Preloaded)
forall a b. (a -> b) -> a -> b
$ m Inspection
-> InspectM ModuleLocation ModuleTag m Preloaded
-> InspectM ModuleLocation ModuleTag m Preloaded
forall (m :: * -> *) k t a.
MonadCatch m =>
m Inspection -> InspectM k t m a -> InspectM k t m a
withInspection (Inspection -> m Inspection
forall (m :: * -> *) a. Monad m => a -> m a
return Inspection
inspection') (InspectM ModuleLocation ModuleTag m Preloaded
 -> InspectM ModuleLocation ModuleTag m Preloaded)
-> InspectM ModuleLocation ModuleTag m Preloaded
-> InspectM ModuleLocation ModuleTag m Preloaded
forall a b. (a -> b) -> a -> b
$ InspectM ModuleLocation ModuleTag m Preloaded
-> InspectM ModuleLocation ModuleTag m Preloaded
forall k a. InspectM k ModuleTag m a -> InspectM k ModuleTag m a
dirtyTag' (InspectM ModuleLocation ModuleTag m Preloaded
 -> InspectM ModuleLocation ModuleTag m Preloaded)
-> InspectM ModuleLocation ModuleTag m Preloaded
-> InspectM ModuleLocation ModuleTag m Preloaded
forall a b. (a -> b) -> a -> b
$ Text
-> [(String, String)]
-> [String]
-> Maybe Text
-> InspectM ModuleLocation ModuleTag m Preloaded
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
Text
-> [(String, String)]
-> [String]
-> Maybe Text
-> InspectM ModuleLocation ModuleTag m Preloaded
preload (ModuleLocation
mloc ModuleLocation -> Getting (Endo Text) ModuleLocation Text -> Text
forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! Getting (Endo Text) ModuleLocation Text
Traversal' ModuleLocation Text
moduleFile) [(String, String)]
defines ([String]
opts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
mopts) Maybe Text
mcts'

		[Inspected ModuleLocation ModuleTag Preloaded]
ploaded <- [m (Inspected ModuleLocation ModuleTag Preloaded)]
-> m [Inspected ModuleLocation ModuleTag Preloaded]
forall (m :: * -> *) a. UpdateMonad m => [m a] -> m [a]
runTasks ((ModuleToScan -> m (Inspected ModuleLocation ModuleTag Preloaded))
-> [ModuleToScan]
-> [m (Inspected ModuleLocation ModuleTag Preloaded)]
forall a b. (a -> b) -> [a] -> [b]
map ModuleToScan -> m (Inspected ModuleLocation ModuleTag Preloaded)
forall (m :: * -> *).
(MonadWriter [ModuleLocation] m, MonadReader UpdateState m,
 CommandMonad m) =>
ModuleToScan -> m (Inspected ModuleLocation ModuleTag Preloaded)
pload [ModuleToScan]
ms')
		ServerM IO () -> m ()
forall (m :: * -> *). UpdateMonad m => ServerM IO () -> m ()
sendUpdateAction (ServerM IO () -> m ()) -> ServerM IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ServerM IO [Int] -> ServerM IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ServerM IO [Int] -> ServerM IO ())
-> ServerM IO [Int] -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ [InspectedModule] -> ServerM IO [Int]
forall (m :: * -> *).
SessionMonad m =>
[InspectedModule] -> m [Int]
SQLite.upsertModules ([InspectedModule] -> ServerM IO [Int])
-> [InspectedModule] -> ServerM IO [Int]
forall a b. (a -> b) -> a -> b
$ (Inspected ModuleLocation ModuleTag Preloaded -> InspectedModule)
-> [Inspected ModuleLocation ModuleTag Preloaded]
-> [InspectedModule]
forall a b. (a -> b) -> [a] -> [b]
map ((Preloaded -> Module)
-> Inspected ModuleLocation ModuleTag Preloaded -> InspectedModule
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Getting Module Preloaded Module -> Preloaded -> Module
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Module Preloaded Module
Lens' Preloaded Module
asModule)) [Inspected ModuleLocation ModuleTag Preloaded]
ploaded
		let
			mlocs' :: [ModuleLocation]
mlocs' = [Inspected ModuleLocation ModuleTag Preloaded]
ploaded [Inspected ModuleLocation ModuleTag Preloaded]
-> Getting
     (Endo [ModuleLocation])
     [Inspected ModuleLocation ModuleTag Preloaded]
     ModuleLocation
-> [ModuleLocation]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. (Inspected ModuleLocation ModuleTag Preloaded
 -> Const
      (Endo [ModuleLocation])
      (Inspected ModuleLocation ModuleTag Preloaded))
-> [Inspected ModuleLocation ModuleTag Preloaded]
-> Const
     (Endo [ModuleLocation])
     [Inspected ModuleLocation ModuleTag Preloaded]
forall s t a b. Each s t a b => Traversal s t a b
each ((Inspected ModuleLocation ModuleTag Preloaded
  -> Const
       (Endo [ModuleLocation])
       (Inspected ModuleLocation ModuleTag Preloaded))
 -> [Inspected ModuleLocation ModuleTag Preloaded]
 -> Const
      (Endo [ModuleLocation])
      [Inspected ModuleLocation ModuleTag Preloaded])
-> ((ModuleLocation
     -> Const (Endo [ModuleLocation]) ModuleLocation)
    -> Inspected ModuleLocation ModuleTag Preloaded
    -> Const
         (Endo [ModuleLocation])
         (Inspected ModuleLocation ModuleTag Preloaded))
-> Getting
     (Endo [ModuleLocation])
     [Inspected ModuleLocation ModuleTag Preloaded]
     ModuleLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Preloaded -> Const (Endo [ModuleLocation]) Preloaded)
-> Inspected ModuleLocation ModuleTag Preloaded
-> Const
     (Endo [ModuleLocation])
     (Inspected ModuleLocation ModuleTag Preloaded)
forall k t a b. Traversal (Inspected k t a) (Inspected k t b) a b
inspected ((Preloaded -> Const (Endo [ModuleLocation]) Preloaded)
 -> Inspected ModuleLocation ModuleTag Preloaded
 -> Const
      (Endo [ModuleLocation])
      (Inspected ModuleLocation ModuleTag Preloaded))
-> ((ModuleLocation
     -> Const (Endo [ModuleLocation]) ModuleLocation)
    -> Preloaded -> Const (Endo [ModuleLocation]) Preloaded)
-> (ModuleLocation -> Const (Endo [ModuleLocation]) ModuleLocation)
-> Inspected ModuleLocation ModuleTag Preloaded
-> Const
     (Endo [ModuleLocation])
     (Inspected ModuleLocation ModuleTag Preloaded)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleId -> Const (Endo [ModuleLocation]) ModuleId)
-> Preloaded -> Const (Endo [ModuleLocation]) Preloaded
Lens' Preloaded ModuleId
preloadedId ((ModuleId -> Const (Endo [ModuleLocation]) ModuleId)
 -> Preloaded -> Const (Endo [ModuleLocation]) Preloaded)
-> ((ModuleLocation
     -> Const (Endo [ModuleLocation]) ModuleLocation)
    -> ModuleId -> Const (Endo [ModuleLocation]) ModuleId)
-> (ModuleLocation -> Const (Endo [ModuleLocation]) ModuleLocation)
-> Preloaded
-> Const (Endo [ModuleLocation]) Preloaded
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleLocation -> Const (Endo [ModuleLocation]) ModuleLocation)
-> ModuleId -> Const (Endo [ModuleLocation]) ModuleId
Lens' ModuleId ModuleLocation
moduleLocation

		[ModuleLocation] -> m ()
forall (m :: * -> *). UpdateMonad m => [ModuleLocation] -> m ()
updater [ModuleLocation]
mlocs'

		let
			mcabal :: Maybe Text
mcabal = Maybe Project
mproj Maybe Project
-> Getting (First Text) (Maybe Project) Text -> Maybe Text
forall s a. s -> Getting (First a) s a -> Maybe a
^? (Project -> Const (First Text) Project)
-> Maybe Project -> Const (First Text) (Maybe Project)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just ((Project -> Const (First Text) Project)
 -> Maybe Project -> Const (First Text) (Maybe Project))
-> ((Text -> Const (First Text) Text)
    -> Project -> Const (First Text) Project)
-> Getting (First Text) (Maybe Project) Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const (First Text) Text)
-> Project -> Const (First Text) Project
Lens' Project Text
projectCabal

		(Environment
env, FixitiesTable
fixities) <- Maybe Text -> m (Environment, FixitiesTable)
forall (m :: * -> *).
SessionMonad m =>
Maybe Text -> m (Environment, FixitiesTable)
loadEnv Maybe Text
mcabal

		Level -> Text -> m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Format
"resolved environment: {} modules" Format -> Int -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ Environment -> Int
forall k a. Map k a -> Int
M.size Environment
env
		case (Inspected ModuleLocation ModuleTag Preloaded -> Maybe Preloaded)
-> [Inspected ModuleLocation ModuleTag Preloaded]
-> Either
     (DepsError Text) [Inspected ModuleLocation ModuleTag Preloaded]
forall a.
(a -> Maybe Preloaded) -> [a] -> Either (DepsError Text) [a]
orderBy (Getting
  (First Preloaded)
  (Inspected ModuleLocation ModuleTag Preloaded)
  Preloaded
-> Inspected ModuleLocation ModuleTag Preloaded -> Maybe Preloaded
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview Getting
  (First Preloaded)
  (Inspected ModuleLocation ModuleTag Preloaded)
  Preloaded
forall k t a b. Traversal (Inspected k t a) (Inspected k t b) a b
inspected) [Inspected ModuleLocation ModuleTag Preloaded]
ploaded of
			Left DepsError Text
err -> Level -> Text -> m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Error (Format
"failed order dependencies for files: {}" Format -> String -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ DepsError Text -> String
forall a. Show a => a -> String
show DepsError Text
err)
			Right [Inspected ModuleLocation ModuleTag Preloaded]
ordered -> do
				([Inspected ModuleLocation ModuleTag Resolved]
ms'', (Environment
updEnv, FixitiesTable
updFixities)) <- (StateT
   (Environment, FixitiesTable)
   m
   [Inspected ModuleLocation ModuleTag Resolved]
 -> (Environment, FixitiesTable)
 -> m ([Inspected ModuleLocation ModuleTag Resolved],
       (Environment, FixitiesTable)))
-> (Environment, FixitiesTable)
-> StateT
     (Environment, FixitiesTable)
     m
     [Inspected ModuleLocation ModuleTag Resolved]
-> m ([Inspected ModuleLocation ModuleTag Resolved],
      (Environment, FixitiesTable))
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT
  (Environment, FixitiesTable)
  m
  [Inspected ModuleLocation ModuleTag Resolved]
-> (Environment, FixitiesTable)
-> m ([Inspected ModuleLocation ModuleTag Resolved],
      (Environment, FixitiesTable))
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Environment
env, FixitiesTable
fixities) (StateT
   (Environment, FixitiesTable)
   m
   [Inspected ModuleLocation ModuleTag Resolved]
 -> m ([Inspected ModuleLocation ModuleTag Resolved],
       (Environment, FixitiesTable)))
-> StateT
     (Environment, FixitiesTable)
     m
     [Inspected ModuleLocation ModuleTag Resolved]
-> m ([Inspected ModuleLocation ModuleTag Resolved],
      (Environment, FixitiesTable))
forall a b. (a -> b) -> a -> b
$ [StateT
   (Environment, FixitiesTable)
   m
   (Inspected ModuleLocation ModuleTag Resolved)]
-> StateT
     (Environment, FixitiesTable)
     m
     [Inspected ModuleLocation ModuleTag Resolved]
forall (m :: * -> *) a. UpdateMonad m => [m a] -> m [a]
runTasks ((Inspected ModuleLocation ModuleTag Preloaded
 -> StateT
      (Environment, FixitiesTable)
      m
      (Inspected ModuleLocation ModuleTag Resolved))
-> [Inspected ModuleLocation ModuleTag Preloaded]
-> [StateT
      (Environment, FixitiesTable)
      m
      (Inspected ModuleLocation ModuleTag Resolved)]
forall a b. (a -> b) -> [a] -> [b]
map Inspected ModuleLocation ModuleTag Preloaded
-> StateT
     (Environment, FixitiesTable)
     m
     (Inspected ModuleLocation ModuleTag Resolved)
forall (m :: * -> *).
(CommandMonad m, MonadReader UpdateState m,
 MonadWriter [ModuleLocation] m,
 MonadState (Environment, FixitiesTable) m) =>
Inspected ModuleLocation ModuleTag Preloaded
-> m (Inspected ModuleLocation ModuleTag Resolved)
inspect' [Inspected ModuleLocation ModuleTag Preloaded]
ordered)
				Maybe Text -> Environment -> FixitiesTable -> m ()
forall (m :: * -> *).
SessionMonad m =>
Maybe Text -> Environment -> FixitiesTable -> m ()
saveEnv Maybe Text
mcabal Environment
updEnv FixitiesTable
updFixities
				[ModuleLocation]
mlocs'' <- Text -> m [ModuleLocation] -> m [ModuleLocation]
forall (m :: * -> *) a. MonadLog m => Text -> m a -> m a
timer Text
"updated scanned modules" (m [ModuleLocation] -> m [ModuleLocation])
-> m [ModuleLocation] -> m [ModuleLocation]
forall a b. (a -> b) -> a -> b
$ do
					Level -> Text -> m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ case Maybe Project
mproj of
						Just Project
proj -> Format
"inserting data for resolved modules of project: {}" Format -> Project -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ Project
proj
						Maybe Project
Nothing -> Text
"inserting data for resolved standalone modules"
					ServerM IO () -> m ()
forall (m :: * -> *). UpdateMonad m => ServerM IO () -> m ()
sendUpdateAction (ServerM IO () -> m ()) -> ServerM IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> ServerM IO () -> ServerM IO ()
forall (m :: * -> *) a.
(MonadLog m, HasCallStack) =>
Text -> m a -> m a
Log.scope Text
"resolved" (ServerM IO () -> ServerM IO ()) -> ServerM IO () -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ Maybe Text
-> [Inspected ModuleLocation ModuleTag Resolved] -> ServerM IO ()
forall (m :: * -> *).
SessionMonad m =>
Maybe Text -> [Inspected ModuleLocation ModuleTag Resolved] -> m ()
updateResolveds Maybe Text
mcabal [Inspected ModuleLocation ModuleTag Resolved]
ms''
					[ModuleLocation] -> m [ModuleLocation]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Inspected ModuleLocation ModuleTag Resolved]
ms'' [Inspected ModuleLocation ModuleTag Resolved]
-> Getting
     (Endo [ModuleLocation])
     [Inspected ModuleLocation ModuleTag Resolved]
     ModuleLocation
-> [ModuleLocation]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. (Inspected ModuleLocation ModuleTag Resolved
 -> Const
      (Endo [ModuleLocation])
      (Inspected ModuleLocation ModuleTag Resolved))
-> [Inspected ModuleLocation ModuleTag Resolved]
-> Const
     (Endo [ModuleLocation])
     [Inspected ModuleLocation ModuleTag Resolved]
forall s t a b. Each s t a b => Traversal s t a b
each ((Inspected ModuleLocation ModuleTag Resolved
  -> Const
       (Endo [ModuleLocation])
       (Inspected ModuleLocation ModuleTag Resolved))
 -> [Inspected ModuleLocation ModuleTag Resolved]
 -> Const
      (Endo [ModuleLocation])
      [Inspected ModuleLocation ModuleTag Resolved])
-> ((ModuleLocation
     -> Const (Endo [ModuleLocation]) ModuleLocation)
    -> Inspected ModuleLocation ModuleTag Resolved
    -> Const
         (Endo [ModuleLocation])
         (Inspected ModuleLocation ModuleTag Resolved))
-> Getting
     (Endo [ModuleLocation])
     [Inspected ModuleLocation ModuleTag Resolved]
     ModuleLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleLocation -> Const (Endo [ModuleLocation]) ModuleLocation)
-> Inspected ModuleLocation ModuleTag Resolved
-> Const
     (Endo [ModuleLocation])
     (Inspected ModuleLocation ModuleTag Resolved)
forall k1 t a k2. Lens (Inspected k1 t a) (Inspected k2 t a) k1 k2
inspectedKey)
				[ModuleLocation] -> m ()
forall (m :: * -> *). UpdateMonad m => [ModuleLocation] -> m ()
updater [ModuleLocation]
mlocs''
				where
					inspect' :: Inspected ModuleLocation ModuleTag Preloaded
-> m (Inspected ModuleLocation ModuleTag Resolved)
inspect' Inspected ModuleLocation ModuleTag Preloaded
pmod = String
-> ModuleLocation
-> m (Inspected ModuleLocation ModuleTag Resolved)
-> m (Inspected ModuleLocation ModuleTag Resolved)
forall t (m :: * -> *) a.
(Display t, UpdateMonad m, NFData a) =>
String -> t -> m a -> m a
runTask String
"scanning" ModuleLocation
ploc (m (Inspected ModuleLocation ModuleTag Resolved)
 -> m (Inspected ModuleLocation ModuleTag Resolved))
-> m (Inspected ModuleLocation ModuleTag Resolved)
-> m (Inspected ModuleLocation ModuleTag Resolved)
forall a b. (a -> b) -> a -> b
$ Text
-> m (Inspected ModuleLocation ModuleTag Resolved)
-> m (Inspected ModuleLocation ModuleTag Resolved)
forall (m :: * -> *) a.
(MonadLog m, HasCallStack) =>
Text -> m a -> m a
Log.scope Text
"module" (m (Inspected ModuleLocation ModuleTag Resolved)
 -> m (Inspected ModuleLocation ModuleTag Resolved))
-> m (Inspected ModuleLocation ModuleTag Resolved)
-> m (Inspected ModuleLocation ModuleTag Resolved)
forall a b. (a -> b) -> a -> b
$ do
						(Environment
env', FixitiesTable
fixities') <- m (Environment, FixitiesTable)
forall s (m :: * -> *). MonadState s m => m s
get
						Inspected ModuleLocation ModuleTag Resolved
r <- Inspected ModuleLocation ModuleTag Preloaded
-> (Preloaded -> InspectM ModuleLocation ModuleTag m Resolved)
-> m (Inspected ModuleLocation ModuleTag Resolved)
forall (m :: * -> *) t k a b.
(Monad m, Ord t) =>
Inspected k t a -> (a -> InspectM k t m b) -> m (Inspected k t b)
continueInspect Inspected ModuleLocation ModuleTag Preloaded
pmod ((Preloaded -> InspectM ModuleLocation ModuleTag m Resolved)
 -> m (Inspected ModuleLocation ModuleTag Resolved))
-> (Preloaded -> InspectM ModuleLocation ModuleTag m Resolved)
-> m (Inspected ModuleLocation ModuleTag Resolved)
forall a b. (a -> b) -> a -> b
$ \Preloaded
p -> do
							Resolved
resolved' <- [InspectM ModuleLocation ModuleTag m Resolved]
-> InspectM ModuleLocation ModuleTag m Resolved
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [
								Environment
-> FixitiesTable
-> Preloaded
-> InspectM ModuleLocation ModuleTag m Resolved
forall (m :: * -> *).
MonadThrow m =>
Environment
-> FixitiesTable
-> Preloaded
-> InspectM ModuleLocation ModuleTag m Resolved
resolveModule Environment
env' FixitiesTable
fixities' Preloaded
p,
								do
									m () -> InspectM ModuleLocation ModuleTag m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Level -> Text -> m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace (Format
"error resolving module {}, falling to resolving just imports/scope" Format -> ModuleLocation -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ (Preloaded
p Preloaded
-> Getting ModuleLocation Preloaded ModuleLocation
-> ModuleLocation
forall s a. s -> Getting a s a -> a
^. (ModuleId -> Const ModuleLocation ModuleId)
-> Preloaded -> Const ModuleLocation Preloaded
Lens' Preloaded ModuleId
preloadedId ((ModuleId -> Const ModuleLocation ModuleId)
 -> Preloaded -> Const ModuleLocation Preloaded)
-> ((ModuleLocation -> Const ModuleLocation ModuleLocation)
    -> ModuleId -> Const ModuleLocation ModuleId)
-> Getting ModuleLocation Preloaded ModuleLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleLocation -> Const ModuleLocation ModuleLocation)
-> ModuleId -> Const ModuleLocation ModuleId
Lens' ModuleId ModuleLocation
moduleLocation)))
									Environment
-> Preloaded -> InspectM ModuleLocation ModuleTag m Resolved
forall (m :: * -> *).
MonadThrow m =>
Environment
-> Preloaded -> InspectM ModuleLocation ModuleTag m Resolved
resolvePreloaded Environment
env' Preloaded
p]
							Resolved -> InspectM ModuleLocation ModuleTag m Resolved
forall (m :: * -> *) a.
(MonadCatch m, NFData a, MonadIO m) =>
a -> m a
eval Resolved
resolved'
						((Environment, FixitiesTable) -> (Environment, FixitiesTable))
-> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (((Environment, FixitiesTable) -> (Environment, FixitiesTable))
 -> m ())
-> ((Environment, FixitiesTable) -> (Environment, FixitiesTable))
-> m ()
forall a b. (a -> b) -> a -> b
$ (Environment, FixitiesTable)
-> (Environment, FixitiesTable) -> (Environment, FixitiesTable)
forall a. Monoid a => a -> a -> a
mappend (
							Environment
-> (Resolved -> Environment) -> Maybe Resolved -> Environment
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Environment
forall a. Monoid a => a
mempty Resolved -> Environment
resolvedEnv (Inspected ModuleLocation ModuleTag Resolved
r Inspected ModuleLocation ModuleTag Resolved
-> Getting
     (First Resolved)
     (Inspected ModuleLocation ModuleTag Resolved)
     Resolved
-> Maybe Resolved
forall s a. s -> Getting (First a) s a -> Maybe a
^? Getting
  (First Resolved)
  (Inspected ModuleLocation ModuleTag Resolved)
  Resolved
forall k t a b. Traversal (Inspected k t a) (Inspected k t b) a b
inspected),
							FixitiesTable
-> (Resolved -> FixitiesTable) -> Maybe Resolved -> FixitiesTable
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FixitiesTable
forall a. Monoid a => a
mempty Resolved -> FixitiesTable
resolvedFixitiesTable (Inspected ModuleLocation ModuleTag Resolved
r Inspected ModuleLocation ModuleTag Resolved
-> Getting
     (First Resolved)
     (Inspected ModuleLocation ModuleTag Resolved)
     Resolved
-> Maybe Resolved
forall s a. s -> Getting (First a) s a -> Maybe a
^? Getting
  (First Resolved)
  (Inspected ModuleLocation ModuleTag Resolved)
  Resolved
forall k t a b. Traversal (Inspected k t a) (Inspected k t b) a b
inspected))
						Inspected ModuleLocation ModuleTag Resolved
-> m (Inspected ModuleLocation ModuleTag Resolved)
forall (m :: * -> *) a. Monad m => a -> m a
return Inspected ModuleLocation ModuleTag Resolved
r
						where
							ploc :: ModuleLocation
ploc = Inspected ModuleLocation ModuleTag Preloaded
pmod Inspected ModuleLocation ModuleTag Preloaded
-> Getting
     (Endo ModuleLocation)
     (Inspected ModuleLocation ModuleTag Preloaded)
     ModuleLocation
-> ModuleLocation
forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! (Preloaded -> Const (Endo ModuleLocation) Preloaded)
-> Inspected ModuleLocation ModuleTag Preloaded
-> Const
     (Endo ModuleLocation)
     (Inspected ModuleLocation ModuleTag Preloaded)
forall k t a b. Traversal (Inspected k t a) (Inspected k t b) a b
inspected ((Preloaded -> Const (Endo ModuleLocation) Preloaded)
 -> Inspected ModuleLocation ModuleTag Preloaded
 -> Const
      (Endo ModuleLocation)
      (Inspected ModuleLocation ModuleTag Preloaded))
-> ((ModuleLocation -> Const (Endo ModuleLocation) ModuleLocation)
    -> Preloaded -> Const (Endo ModuleLocation) Preloaded)
-> Getting
     (Endo ModuleLocation)
     (Inspected ModuleLocation ModuleTag Preloaded)
     ModuleLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleId -> Const (Endo ModuleLocation) ModuleId)
-> Preloaded -> Const (Endo ModuleLocation) Preloaded
Lens' Preloaded ModuleId
preloadedId ((ModuleId -> Const (Endo ModuleLocation) ModuleId)
 -> Preloaded -> Const (Endo ModuleLocation) Preloaded)
-> ((ModuleLocation -> Const (Endo ModuleLocation) ModuleLocation)
    -> ModuleId -> Const (Endo ModuleLocation) ModuleId)
-> (ModuleLocation -> Const (Endo ModuleLocation) ModuleLocation)
-> Preloaded
-> Const (Endo ModuleLocation) Preloaded
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleLocation -> Const (Endo ModuleLocation) ModuleLocation)
-> ModuleId -> Const (Endo ModuleLocation) ModuleId
Lens' ModuleId ModuleLocation
moduleLocation

	grouped :: [(Maybe Project, [ModuleToScan])]
grouped = Map (Maybe Project) [ModuleToScan]
-> [(Maybe Project, [ModuleToScan])]
forall k a. Map k a -> [(k, a)]
M.toList (Map (Maybe Project) [ModuleToScan]
 -> [(Maybe Project, [ModuleToScan])])
-> Map (Maybe Project) [ModuleToScan]
-> [(Maybe Project, [ModuleToScan])]
forall a b. (a -> b) -> a -> b
$ ([ModuleToScan] -> [ModuleToScan] -> [ModuleToScan])
-> [Map (Maybe Project) [ModuleToScan]]
-> Map (Maybe Project) [ModuleToScan]
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
M.unionsWith [ModuleToScan] -> [ModuleToScan] -> [ModuleToScan]
forall a. [a] -> [a] -> [a]
(++) [Maybe Project
-> [ModuleToScan] -> Map (Maybe Project) [ModuleToScan]
forall k a. k -> a -> Map k a
M.singleton (ModuleToScan
m ModuleToScan
-> Getting (First Project) ModuleToScan Project -> Maybe Project
forall s a. s -> Getting (First a) s a -> Maybe a
^? (ModuleLocation -> Const (First Project) ModuleLocation)
-> ModuleToScan -> Const (First Project) ModuleToScan
forall s t a b. Field1 s t a b => Lens s t a b
_1 ((ModuleLocation -> Const (First Project) ModuleLocation)
 -> ModuleToScan -> Const (First Project) ModuleToScan)
-> ((Project -> Const (First Project) Project)
    -> ModuleLocation -> Const (First Project) ModuleLocation)
-> Getting (First Project) ModuleToScan Project
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Project -> Const (First Project) (Maybe Project))
-> ModuleLocation -> Const (First Project) ModuleLocation
Traversal' ModuleLocation (Maybe Project)
moduleProject ((Maybe Project -> Const (First Project) (Maybe Project))
 -> ModuleLocation -> Const (First Project) ModuleLocation)
-> ((Project -> Const (First Project) Project)
    -> Maybe Project -> Const (First Project) (Maybe Project))
-> (Project -> Const (First Project) Project)
-> ModuleLocation
-> Const (First Project) ModuleLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Project -> Const (First Project) Project)
-> Maybe Project -> Const (First Project) (Maybe Project)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just) [ModuleToScan
m] | ModuleToScan
m <- [ModuleToScan]
ms]
	eval :: a -> m a
eval a
v = (ErrorCall -> m a) -> m a -> m a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle ErrorCall -> m a
forall (m :: * -> *) a. MonadThrow m => ErrorCall -> m a
onError (a
v a -> m a -> m a
forall a b. NFData a => a -> b -> b
`deepseq` IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (a -> IO a
forall a. a -> IO a
evaluate a
v)) where
		onError :: MonadThrow m => ErrorCall -> m a
		onError :: ErrorCall -> m a
onError = HsDevError -> m a
forall (m :: * -> *) a. MonadThrow m => HsDevError -> m a
hsdevError (HsDevError -> m a)
-> (ErrorCall -> HsDevError) -> ErrorCall -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HsDevError
OtherError (String -> HsDevError)
-> (ErrorCall -> String) -> ErrorCall -> HsDevError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorCall -> String
forall e. Exception e => e -> String
displayException

-- | Scan source file, possibly scanning also related project and installed modules
scanFile :: UpdateMonad m => [String] -> Path -> BuildTool -> Bool -> Bool -> m ()
scanFile :: [String] -> Text -> BuildTool -> Bool -> Bool -> m ()
scanFile [String]
opts Text
fpath BuildTool
tool Bool
scanProj Bool
scanDb = do
	Maybe Project
mproj <- (Maybe Project -> Maybe Project)
-> m (Maybe Project) -> m (Maybe Project)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ASetter (Maybe Project) (Maybe Project) BuildTool BuildTool
-> BuildTool -> Maybe Project -> Maybe Project
forall s t a b. ASetter s t a b -> b -> s -> t
set ((Project -> Identity Project)
-> Maybe Project -> Identity (Maybe Project)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just ((Project -> Identity Project)
 -> Maybe Project -> Identity (Maybe Project))
-> ((BuildTool -> Identity BuildTool)
    -> Project -> Identity Project)
-> ASetter (Maybe Project) (Maybe Project) BuildTool BuildTool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BuildTool -> Identity BuildTool) -> Project -> Identity Project
Lens' Project BuildTool
projectBuildTool) BuildTool
tool) (m (Maybe Project) -> m (Maybe Project))
-> m (Maybe Project) -> m (Maybe Project)
forall a b. (a -> b) -> a -> b
$ Text -> m (Maybe Project)
forall (m :: * -> *). UpdateMonad m => Text -> m (Maybe Project)
locateProjectInfo Text
fpath
	PackageDbStack
sbox <- m PackageDbStack
-> (Project -> m PackageDbStack)
-> Maybe Project
-> m PackageDbStack
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (PackageDbStack -> m PackageDbStack
forall (m :: * -> *) a. Monad m => a -> m a
return PackageDbStack
userDb) (GhcM PackageDbStack -> m PackageDbStack
forall (m :: * -> *) a. SessionMonad m => GhcM a -> m a
inSessionGhc (GhcM PackageDbStack -> m PackageDbStack)
-> (Project -> GhcM PackageDbStack) -> Project -> m PackageDbStack
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Project -> GhcM PackageDbStack
getProjectPackageDbStack) Maybe Project
mproj
	Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
scanDb (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
		[SQLite.Only Bool
scanned] <- Query -> Only PackageDb -> m [Only Bool]
forall q r (m :: * -> *).
(ToRow q, FromRow r, SessionMonad m) =>
Query -> q -> m [r]
SQLite.query @_ @(SQLite.Only Bool) Query
"select count(*) > 0 from package_dbs as pdbs where pdbs.package_db = ?;" (PackageDb -> Only PackageDb
forall a. a -> Only a
SQLite.Only (PackageDbStack -> PackageDb
topPackageDb PackageDbStack
sbox))
		Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
scanned (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ [String] -> PackageDbStack -> m ()
forall (m :: * -> *).
UpdateMonad m =>
[String] -> PackageDbStack -> m ()
scanPackageDbStack [String]
opts PackageDbStack
sbox
	case Maybe (Maybe Project) -> Maybe Project
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe Project
mproj Maybe Project -> Bool -> Maybe (Maybe Project)
forall a. a -> Bool -> Maybe a
`justIf` Bool
scanProj) of
		Maybe Project
Nothing -> [(FileSource, [String])] -> m ()
forall (m :: * -> *).
UpdateMonad m =>
[(FileSource, [String])] -> m ()
scanFiles [(Text -> Maybe Text -> FileSource
FileSource Text
fpath Maybe Text
forall a. Maybe a
Nothing, [String]
opts)]
		Just Project
proj -> [String] -> BuildTool -> Text -> m ()
forall (m :: * -> *).
UpdateMonad m =>
[String] -> BuildTool -> Text -> m ()
scanProject [String]
opts BuildTool
tool (Getting Text Project Text -> Project -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text Project Text
Lens' Project Text
projectCabal Project
proj)

-- | Scan source files, resolving dependent modules
scanFiles :: UpdateMonad m => [(FileSource, [String])] -> m ()
scanFiles :: [(FileSource, [String])] -> m ()
scanFiles [(FileSource, [String])]
fsrcs = String -> String -> m () -> m ()
forall t (m :: * -> *) a.
(Display t, UpdateMonad m, NFData a) =>
String -> t -> m a -> m a
runTask String
"scanning" (String
"files" :: String) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> m () -> m ()
forall (m :: * -> *) a.
(MonadLog m, HasCallStack) =>
Text -> m a -> m a
Log.scope Text
"files" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ m () -> m ()
forall (m :: * -> *) a. MonadCatch m => m a -> m a
hsdevLiftIO (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
	Level -> Text -> m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Format
"scanning {} files" Format -> Int -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ [(FileSource, [String])] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(FileSource, [String])]
fsrcs
	[Text]
fpaths' <- (Text -> m Text) -> [Text] -> m [Text]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (IO Text -> m Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> m Text) -> (Text -> IO Text) -> Text -> m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> IO Text
forall a. Paths a => a -> IO a
canonicalize) ([Text] -> m [Text]) -> [Text] -> m [Text]
forall a b. (a -> b) -> a -> b
$ ((FileSource, [String]) -> Text)
-> [(FileSource, [String])] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (FileSource -> Text
fileSource (FileSource -> Text)
-> ((FileSource, [String]) -> FileSource)
-> (FileSource, [String])
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FileSource, [String]) -> FileSource
forall a b. (a, b) -> a
fst) [(FileSource, [String])]
fsrcs
	[Text] -> (Text -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Text]
fpaths' ((Text -> m ()) -> m ()) -> (Text -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Text
fpath' -> do
		Bool
ex <- IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Text -> IO Bool
fileExists Text
fpath'
		Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ex (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ HsDevError -> m ()
forall (m :: * -> *) a. MonadThrow m => HsDevError -> m a
hsdevError (HsDevError -> m ()) -> HsDevError -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> HsDevError
FileNotFound Text
fpath'
	[ModuleLocation]
mlocs <- [Text] -> (Text -> m ModuleLocation) -> m [ModuleLocation]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Text]
fpaths' ((Text -> m ModuleLocation) -> m [ModuleLocation])
-> (Text -> m ModuleLocation) -> m [ModuleLocation]
forall a b. (a -> b) -> a -> b
$ \Text
fpath' -> do
		[ModuleId]
mids <- Query -> Only Text -> m [ModuleId]
forall q r (m :: * -> *).
(ToRow q, FromRow r, SessionMonad m) =>
Query -> q -> m [r]
SQLite.query (Select Text -> Query
SQLite.toQuery (Select Text -> Query) -> Select Text -> Query
forall a b. (a -> b) -> a -> b
$ Select Text
SQLite.qModuleId Select Text -> Select Text -> Select Text
forall a. Monoid a => a -> a -> a
`mappend` [Text] -> Select Text
forall a. [a] -> Select a
SQLite.where_ [Text
"mu.file == ?"]) (Text -> Only Text
forall a. a -> Only a
SQLite.Only Text
fpath')
		if [ModuleId] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ModuleId]
mids Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
			then ModuleLocation -> m ModuleLocation
forall (m :: * -> *) a. Monad m => a -> m a
return ([ModuleId] -> ModuleId
forall a. [a] -> a
head [ModuleId]
mids ModuleId
-> ((ModuleLocation -> Const ModuleLocation ModuleLocation)
    -> ModuleId -> Const ModuleLocation ModuleId)
-> ModuleLocation
forall s a. s -> Getting a s a -> a
^. (ModuleLocation -> Const ModuleLocation ModuleLocation)
-> ModuleId -> Const ModuleLocation ModuleId
Lens' ModuleId ModuleLocation
moduleLocation)
			else do
				Maybe Project
mproj <- Text -> m (Maybe Project)
forall (m :: * -> *). UpdateMonad m => Text -> m (Maybe Project)
locateProjectInfo Text
fpath'
				ModuleLocation -> m ModuleLocation
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleLocation -> m ModuleLocation)
-> ModuleLocation -> m ModuleLocation
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Project -> ModuleLocation
FileModule Text
fpath' Maybe Project
mproj
	let
		filesMods :: m [Only Int :. (ModuleLocation :. Inspection)]
filesMods = ([[Only Int :. (ModuleLocation :. Inspection)]]
 -> [Only Int :. (ModuleLocation :. Inspection)])
-> m [[Only Int :. (ModuleLocation :. Inspection)]]
-> m [Only Int :. (ModuleLocation :. Inspection)]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[Only Int :. (ModuleLocation :. Inspection)]]
-> [Only Int :. (ModuleLocation :. Inspection)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (m [[Only Int :. (ModuleLocation :. Inspection)]]
 -> m [Only Int :. (ModuleLocation :. Inspection)])
-> m [[Only Int :. (ModuleLocation :. Inspection)]]
-> m [Only Int :. (ModuleLocation :. Inspection)]
forall a b. (a -> b) -> a -> b
$ [Text]
-> (Text -> m [Only Int :. (ModuleLocation :. Inspection)])
-> m [[Only Int :. (ModuleLocation :. Inspection)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Text]
fpaths' ((Text -> m [Only Int :. (ModuleLocation :. Inspection)])
 -> m [[Only Int :. (ModuleLocation :. Inspection)]])
-> (Text -> m [Only Int :. (ModuleLocation :. Inspection)])
-> m [[Only Int :. (ModuleLocation :. Inspection)]]
forall a b. (a -> b) -> a -> b
$ \Text
fpath' -> Query
-> Only Text -> m [Only Int :. (ModuleLocation :. Inspection)]
forall q r (m :: * -> *).
(ToRow q, FromRow r, SessionMonad m) =>
Query -> q -> m [r]
SQLite.query 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 == ?;" (Text -> Only Text
forall a. a -> Only a
SQLite.Only Text
fpath')
	m [Only Int :. (ModuleLocation :. Inspection)]
-> [ModuleToScan] -> [String] -> ([ModuleToScan] -> m ()) -> m ()
forall (m :: * -> *).
UpdateMonad m =>
m [Only Int :. (ModuleLocation :. Inspection)]
-> [ModuleToScan] -> [String] -> ([ModuleToScan] -> m ()) -> m ()
scan m [Only Int :. (ModuleLocation :. Inspection)]
filesMods [(ModuleLocation
mloc, [String]
opts, Maybe Text
mcts) | (ModuleLocation
mloc, (FileSource Text
_ Maybe Text
mcts, [String]
opts)) <- [ModuleLocation]
-> [(FileSource, [String])]
-> [(ModuleLocation, (FileSource, [String]))]
forall a b. [a] -> [b] -> [(a, b)]
zip [ModuleLocation]
mlocs [(FileSource, [String])]
fsrcs] [] (([ModuleToScan] -> m ()) -> m ())
-> ([ModuleToScan] -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \[ModuleToScan]
mlocs' -> do
		(ModuleToScan -> m ()) -> [ModuleToScan] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (((Watcher -> IO ()) -> m ()
forall (m :: * -> *). SessionMonad m => (Watcher -> IO ()) -> m ()
watch ((Watcher -> IO ()) -> m ())
-> (ModuleLocation -> Watcher -> IO ()) -> ModuleLocation -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Watcher -> ModuleLocation -> IO ())
-> ModuleLocation -> Watcher -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Watcher -> ModuleLocation -> IO ()
watchModule) (ModuleLocation -> m ())
-> (ModuleToScan -> ModuleLocation) -> ModuleToScan -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting ModuleLocation ModuleToScan ModuleLocation
-> ModuleToScan -> ModuleLocation
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ModuleLocation ModuleToScan ModuleLocation
forall s t a b. Field1 s t a b => Lens s t a b
_1) [ModuleToScan]
mlocs'
		S.ScanContents [ModuleToScan]
dmods [ProjectToScan]
_ [PackageDbStack]
_ <- ([ScanContents] -> ScanContents)
-> m [ScanContents] -> m ScanContents
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [ScanContents] -> ScanContents
forall a. Monoid a => [a] -> a
mconcat (m [ScanContents] -> m ScanContents)
-> m [ScanContents] -> m ScanContents
forall a b. (a -> b) -> a -> b
$ (ModuleToScan -> m ScanContents)
-> [ModuleToScan] -> m [ScanContents]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> m ScanContents
forall (m :: * -> *). CommandMonad m => String -> m ScanContents
S.enumDependent (String -> m ScanContents)
-> (ModuleToScan -> String) -> ModuleToScan -> m ScanContents
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting String ModuleToScan String -> ModuleToScan -> String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((ModuleLocation -> Const String ModuleLocation)
-> ModuleToScan -> Const String ModuleToScan
forall s t a b. Field1 s t a b => Lens s t a b
_1 ((ModuleLocation -> Const String ModuleLocation)
 -> ModuleToScan -> Const String ModuleToScan)
-> ((String -> Const String String)
    -> ModuleLocation -> Const String ModuleLocation)
-> Getting String ModuleToScan String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const String Text)
-> ModuleLocation -> Const String ModuleLocation
Traversal' ModuleLocation Text
moduleFile ((Text -> Const String Text)
 -> ModuleLocation -> Const String ModuleLocation)
-> ((String -> Const String String) -> Text -> Const String Text)
-> (String -> Const String String)
-> ModuleLocation
-> Const String ModuleLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Const String String) -> Text -> Const String Text
Lens' Text String
path)) [ModuleToScan]
mlocs'
		Level -> Text -> m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Format
"dependent modules: {}" Format -> Int -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ [ModuleToScan] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ModuleToScan]
dmods
		[String] -> [ModuleToScan] -> m ()
forall (m :: * -> *).
UpdateMonad m =>
[String] -> [ModuleToScan] -> m ()
scanModules [] ([ModuleToScan]
mlocs' [ModuleToScan] -> [ModuleToScan] -> [ModuleToScan]
forall a. [a] -> [a] -> [a]
++ [ModuleToScan]
dmods)

-- | Scan source file with contents and resolve dependent modules
scanFileContents :: UpdateMonad m => [String] -> Path -> Maybe Text -> m ()
scanFileContents :: [String] -> Text -> Maybe Text -> m ()
scanFileContents [String]
opts Text
fpath Maybe Text
mcts = [(FileSource, [String])] -> m ()
forall (m :: * -> *).
UpdateMonad m =>
[(FileSource, [String])] -> m ()
scanFiles [(Text -> Maybe Text -> FileSource
FileSource Text
fpath Maybe Text
mcts, [String]
opts)]

-- | Scan cabal modules, doesn't rescan if already scanned
scanCabal :: UpdateMonad m => [String] -> m ()
scanCabal :: [String] -> m ()
scanCabal [String]
opts = Text -> m () -> m ()
forall (m :: * -> *) a.
(MonadLog m, HasCallStack) =>
Text -> m a -> m a
Log.scope Text
"cabal" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ [String] -> PackageDbStack -> m ()
forall (m :: * -> *).
UpdateMonad m =>
[String] -> PackageDbStack -> m ()
scanPackageDbStack [String]
opts PackageDbStack
userDb

-- | Prepare sandbox for scanning. This is used for stack project to build & configure.
prepareSandbox :: UpdateMonad m => Sandbox -> m ()
prepareSandbox :: Sandbox -> m ()
prepareSandbox sbox :: Sandbox
sbox@(Sandbox BuildTool
StackTool Text
fpath) = Text -> m () -> m ()
forall (m :: * -> *) a.
(MonadLog m, HasCallStack) =>
Text -> m a -> m a
Log.scope Text
"prepare" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ [m ()] -> m ()
forall (m :: * -> *). UpdateMonad m => [m ()] -> m ()
runTasks_ [
	String -> Sandbox -> m () -> m ()
forall t (m :: * -> *) a.
(Display t, UpdateMonad m, NFData a) =>
String -> t -> m a -> m a
runTask String
"building dependencies" Sandbox
sbox (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ m () -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> m () -> m ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> m a -> m a
Util.withCurrentDirectory String
dir (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ GhcM () -> m ()
forall (m :: * -> *) a. SessionMonad m => GhcM a -> m a
inSessionGhc (GhcM () -> m ()) -> GhcM () -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe String -> GhcM ()
S.buildDeps Maybe String
forall a. Maybe a
Nothing]
	where
		dir :: String
dir = String -> String
takeDirectory (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ ((String -> Const String String) -> Text -> Const String Text)
-> Text -> String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (String -> Const String String) -> Text -> Const String Text
Lens' Text String
path Text
fpath
prepareSandbox Sandbox
_ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Scan sandbox modules, doesn't rescan if already scanned
scanSandbox :: UpdateMonad m => [String] -> Sandbox -> m ()
scanSandbox :: [String] -> Sandbox -> m ()
scanSandbox [String]
opts Sandbox
sbox = Text -> m () -> m ()
forall (m :: * -> *) a.
(MonadLog m, HasCallStack) =>
Text -> m a -> m a
Log.scope Text
"sandbox" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
	-- prepareSandbox sbox
	PackageDbStack
pdbs <- GhcM PackageDbStack -> m PackageDbStack
forall (m :: * -> *) a. SessionMonad m => GhcM a -> m a
inSessionGhc (GhcM PackageDbStack -> m PackageDbStack)
-> GhcM PackageDbStack -> m PackageDbStack
forall a b. (a -> b) -> a -> b
$ Sandbox -> GhcM PackageDbStack
sandboxPackageDbStack Sandbox
sbox
	[String] -> PackageDbStack -> m ()
forall (m :: * -> *).
UpdateMonad m =>
[String] -> PackageDbStack -> m ()
scanPackageDbStack [String]
opts PackageDbStack
pdbs

-- | Scan top of package-db stack, usable for rescan
scanPackageDb :: UpdateMonad m => [String] -> PackageDbStack -> m ()
scanPackageDb :: [String] -> PackageDbStack -> m ()
scanPackageDb [String]
opts PackageDbStack
pdbs = String -> PackageDb -> m () -> m ()
forall t (m :: * -> *) a.
(Display t, UpdateMonad m, NFData a) =>
String -> t -> m a -> m a
runTask String
"scanning" (PackageDbStack -> PackageDb
topPackageDb PackageDbStack
pdbs) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> m () -> m ()
forall (m :: * -> *) a.
(MonadLog m, HasCallStack) =>
Text -> m a -> m a
Log.scope Text
"package-db" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
	Map ModulePackage [ModuleLocation]
pdbState <- IO (Map ModulePackage [ModuleLocation])
-> m (Map ModulePackage [ModuleLocation])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map ModulePackage [ModuleLocation])
 -> m (Map ModulePackage [ModuleLocation]))
-> IO (Map ModulePackage [ModuleLocation])
-> m (Map ModulePackage [ModuleLocation])
forall a b. (a -> b) -> a -> b
$ PackageDb -> IO (Map ModulePackage [ModuleLocation])
readPackageDb (PackageDbStack -> PackageDb
topPackageDb PackageDbStack
pdbs)
	let
		packageDbMods :: Set ModuleLocation
packageDbMods = [ModuleLocation] -> Set ModuleLocation
forall a. Ord a => [a] -> Set a
S.fromList ([ModuleLocation] -> Set ModuleLocation)
-> [ModuleLocation] -> Set ModuleLocation
forall a b. (a -> b) -> a -> b
$ [[ModuleLocation]] -> [ModuleLocation]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[ModuleLocation]] -> [ModuleLocation])
-> [[ModuleLocation]] -> [ModuleLocation]
forall a b. (a -> b) -> a -> b
$ Map ModulePackage [ModuleLocation] -> [[ModuleLocation]]
forall k a. Map k a -> [a]
M.elems Map ModulePackage [ModuleLocation]
pdbState
		packages' :: [ModulePackage]
packages' = Map ModulePackage [ModuleLocation] -> [ModulePackage]
forall k a. Map k a -> [k]
M.keys Map ModulePackage [ModuleLocation]
pdbState
	Level -> Text -> m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Format
"package-db state: {} modules" Format -> Int -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ Set ModuleLocation -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Set ModuleLocation
packageDbMods
	(Watcher -> IO ()) -> m ()
forall (m :: * -> *). SessionMonad m => (Watcher -> IO ()) -> m ()
watch (\Watcher
w -> Watcher -> PackageDbStack -> [String] -> IO ()
watchPackageDb Watcher
w PackageDbStack
pdbs [String]
opts)

	[ModulePackage]
pkgs <- Query -> Only PackageDb -> m [ModulePackage]
forall q r (m :: * -> *).
(ToRow q, FromRow r, SessionMonad m) =>
Query -> q -> m [r]
SQLite.query Query
"select package_name, package_version from package_dbs where package_db == ?;" (PackageDb -> Only PackageDb
forall a. a -> Only a
SQLite.Only (PackageDb -> Only PackageDb) -> PackageDb -> Only PackageDb
forall a b. (a -> b) -> a -> b
$ PackageDbStack -> PackageDb
topPackageDb PackageDbStack
pdbs)
	if [ModulePackage] -> Set ModulePackage
forall a. Ord a => [a] -> Set a
S.fromList [ModulePackage]
packages' Set ModulePackage -> Set ModulePackage -> Bool
forall a. Eq a => a -> a -> Bool
== [ModulePackage] -> Set ModulePackage
forall a. Ord a => [a] -> Set a
S.fromList [ModulePackage]
pkgs
		then Level -> Text -> m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace Text
"nothing changes, all packages the same"
		else do
			[ModuleLocation]
mlocs <- ([ModuleLocation] -> [ModuleLocation])
-> m [ModuleLocation] -> m [ModuleLocation]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
				((ModuleLocation -> Bool) -> [ModuleLocation] -> [ModuleLocation]
forall a. (a -> Bool) -> [a] -> [a]
filter (ModuleLocation -> Set ModuleLocation -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set ModuleLocation
packageDbMods)) (m [ModuleLocation] -> m [ModuleLocation])
-> m [ModuleLocation] -> m [ModuleLocation]
forall a b. (a -> b) -> a -> b
$
				(GhcM [ModuleLocation] -> m [ModuleLocation]
forall (m :: * -> *) a. SessionMonad m => GhcM a -> m a
inSessionGhc (GhcM [ModuleLocation] -> m [ModuleLocation])
-> GhcM [ModuleLocation] -> m [ModuleLocation]
forall a b. (a -> b) -> a -> b
$ [String]
-> PackageDbStack -> [ModulePackage] -> GhcM [ModuleLocation]
listModules [String]
opts PackageDbStack
pdbs [ModulePackage]
packages')
			let
				umlocs :: [ModuleLocation]
umlocs = [ModuleLocation] -> [ModuleLocation]
uniqueModuleLocations [ModuleLocation]
mlocs
			Level -> Text -> m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Format
"{} modules found, {} unique" Format -> Int -> Format
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ [ModuleLocation] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ModuleLocation]
mlocs Format -> Int -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ [ModuleLocation] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ModuleLocation]
umlocs
			let
				packageDbMods' :: m [Only Int :. (ModuleLocation :. Inspection)]
packageDbMods' = Query
-> Only PackageDb -> m [Only Int :. (ModuleLocation :. Inspection)]
forall q r (m :: * -> *).
(ToRow q, FromRow r, SessionMonad m) =>
Query -> q -> m [r]
SQLite.query 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 == ?;" (PackageDb -> Only PackageDb
forall a. a -> Only a
SQLite.Only (PackageDbStack -> PackageDb
topPackageDb PackageDbStack
pdbs))
			m [Only Int :. (ModuleLocation :. Inspection)]
-> [ModuleToScan] -> [String] -> ([ModuleToScan] -> m ()) -> m ()
forall (m :: * -> *).
UpdateMonad m =>
m [Only Int :. (ModuleLocation :. Inspection)]
-> [ModuleToScan] -> [String] -> ([ModuleToScan] -> m ()) -> m ()
scan m [Only Int :. (ModuleLocation :. Inspection)]
packageDbMods' ((,,) (ModuleLocation -> [String] -> Maybe Text -> ModuleToScan)
-> [ModuleLocation] -> [[String] -> Maybe Text -> ModuleToScan]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModuleLocation]
umlocs [[String] -> Maybe Text -> ModuleToScan]
-> [[String]] -> [Maybe Text -> ModuleToScan]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [String] -> [[String]]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [] [Maybe Text -> ModuleToScan] -> [Maybe Text] -> [ModuleToScan]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Text -> [Maybe Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing) [String]
opts (([ModuleToScan] -> m ()) -> m ())
-> ([ModuleToScan] -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \[ModuleToScan]
mlocs' -> do
				[InspectedModule]
ms <- GhcM [InspectedModule] -> m [InspectedModule]
forall (m :: * -> *) a. SessionMonad m => GhcM a -> m a
inSessionGhc (GhcM [InspectedModule] -> m [InspectedModule])
-> GhcM [InspectedModule] -> m [InspectedModule]
forall a b. (a -> b) -> a -> b
$ [String]
-> PackageDbStack -> [ModuleLocation] -> GhcM [InspectedModule]
browseModules [String]
opts PackageDbStack
pdbs ([ModuleToScan]
mlocs' [ModuleToScan]
-> Getting (Endo [ModuleLocation]) [ModuleToScan] ModuleLocation
-> [ModuleLocation]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. (ModuleToScan -> Const (Endo [ModuleLocation]) ModuleToScan)
-> [ModuleToScan] -> Const (Endo [ModuleLocation]) [ModuleToScan]
forall s t a b. Each s t a b => Traversal s t a b
each ((ModuleToScan -> Const (Endo [ModuleLocation]) ModuleToScan)
 -> [ModuleToScan] -> Const (Endo [ModuleLocation]) [ModuleToScan])
-> ((ModuleLocation
     -> Const (Endo [ModuleLocation]) ModuleLocation)
    -> ModuleToScan -> Const (Endo [ModuleLocation]) ModuleToScan)
-> Getting (Endo [ModuleLocation]) [ModuleToScan] ModuleLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleLocation -> Const (Endo [ModuleLocation]) ModuleLocation)
-> ModuleToScan -> Const (Endo [ModuleLocation]) ModuleToScan
forall s t a b. Field1 s t a b => Lens s t a b
_1)
				Level -> Text -> m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Format
"scanned {} modules" Format -> Int -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ [InspectedModule] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [InspectedModule]
ms
				ServerM IO () -> m ()
forall (m :: * -> *). UpdateMonad m => ServerM IO () -> m ()
sendUpdateAction (ServerM IO () -> m ()) -> ServerM IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> ServerM IO () -> ServerM IO ()
forall (m :: * -> *) a. MonadLog m => Text -> m a -> m a
timer Text
"updated package-db modules" (ServerM IO () -> ServerM IO ()) -> ServerM IO () -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ do
					[InspectedModule] -> ServerM IO ()
forall (m :: * -> *). SessionMonad m => [InspectedModule] -> m ()
SQLite.updateModules [InspectedModule]
ms
					PackageDb -> [ModulePackage] -> ServerM IO ()
forall (m :: * -> *).
SessionMonad m =>
PackageDb -> [ModulePackage] -> m ()
SQLite.updatePackageDb (PackageDbStack -> PackageDb
topPackageDb PackageDbStack
pdbs) (Map ModulePackage [ModuleLocation] -> [ModulePackage]
forall k a. Map k a -> [k]
M.keys Map ModulePackage [ModuleLocation]
pdbState)

				Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
hdocsSupported (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ [String] -> PackageDbStack -> m ()
forall (m :: * -> *).
UpdateMonad m =>
[String] -> PackageDbStack -> m ()
scanPackageDbStackDocs [String]
opts PackageDbStack
pdbs

				[ModuleLocation] -> m ()
forall (m :: * -> *). UpdateMonad m => [ModuleLocation] -> m ()
updater ([ModuleLocation] -> m ()) -> [ModuleLocation] -> m ()
forall a b. (a -> b) -> a -> b
$ [InspectedModule]
ms [InspectedModule]
-> Getting (Endo [ModuleLocation]) [InspectedModule] ModuleLocation
-> [ModuleLocation]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. (InspectedModule -> Const (Endo [ModuleLocation]) InspectedModule)
-> [InspectedModule]
-> Const (Endo [ModuleLocation]) [InspectedModule]
forall s t a b. Each s t a b => Traversal s t a b
each ((InspectedModule -> Const (Endo [ModuleLocation]) InspectedModule)
 -> [InspectedModule]
 -> Const (Endo [ModuleLocation]) [InspectedModule])
-> ((ModuleLocation
     -> Const (Endo [ModuleLocation]) ModuleLocation)
    -> InspectedModule
    -> Const (Endo [ModuleLocation]) InspectedModule)
-> Getting (Endo [ModuleLocation]) [InspectedModule] ModuleLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleLocation -> Const (Endo [ModuleLocation]) ModuleLocation)
-> InspectedModule -> Const (Endo [ModuleLocation]) InspectedModule
forall k1 t a k2. Lens (Inspected k1 t a) (Inspected k2 t a) k1 k2
inspectedKey

-- | Scan top of package-db stack, usable for rescan
scanPackageDbStack :: UpdateMonad m => [String] -> PackageDbStack -> m ()
scanPackageDbStack :: [String] -> PackageDbStack -> m ()
scanPackageDbStack [String]
opts PackageDbStack
pdbs = String -> PackageDbStack -> m () -> m ()
forall t (m :: * -> *) a.
(Display t, UpdateMonad m, NFData a) =>
String -> t -> m a -> m a
runTask String
"scanning" PackageDbStack
pdbs (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> m () -> m ()
forall (m :: * -> *) a.
(MonadLog m, HasCallStack) =>
Text -> m a -> m a
Log.scope Text
"package-db-stack" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
	[Map ModulePackage [ModuleLocation]]
pdbStates <- IO [Map ModulePackage [ModuleLocation]]
-> m [Map ModulePackage [ModuleLocation]]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Map ModulePackage [ModuleLocation]]
 -> m [Map ModulePackage [ModuleLocation]])
-> IO [Map ModulePackage [ModuleLocation]]
-> m [Map ModulePackage [ModuleLocation]]
forall a b. (a -> b) -> a -> b
$ (PackageDb -> IO (Map ModulePackage [ModuleLocation]))
-> [PackageDb] -> IO [Map ModulePackage [ModuleLocation]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM PackageDb -> IO (Map ModulePackage [ModuleLocation])
readPackageDb (PackageDbStack -> [PackageDb]
packageDbs PackageDbStack
pdbs)
	let
		packageDbMods :: Set ModuleLocation
packageDbMods = [ModuleLocation] -> Set ModuleLocation
forall a. Ord a => [a] -> Set a
S.fromList ([ModuleLocation] -> Set ModuleLocation)
-> [ModuleLocation] -> Set ModuleLocation
forall a b. (a -> b) -> a -> b
$ [[ModuleLocation]] -> [ModuleLocation]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[ModuleLocation]] -> [ModuleLocation])
-> [[ModuleLocation]] -> [ModuleLocation]
forall a b. (a -> b) -> a -> b
$ (Map ModulePackage [ModuleLocation] -> [[ModuleLocation]])
-> [Map ModulePackage [ModuleLocation]] -> [[ModuleLocation]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Map ModulePackage [ModuleLocation] -> [[ModuleLocation]]
forall k a. Map k a -> [a]
M.elems [Map ModulePackage [ModuleLocation]]
pdbStates
		packages' :: [ModulePackage]
packages' = [ModulePackage] -> [ModulePackage]
forall a. Ord a => [a] -> [a]
ordNub ([ModulePackage] -> [ModulePackage])
-> [ModulePackage] -> [ModulePackage]
forall a b. (a -> b) -> a -> b
$ (Map ModulePackage [ModuleLocation] -> [ModulePackage])
-> [Map ModulePackage [ModuleLocation]] -> [ModulePackage]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Map ModulePackage [ModuleLocation] -> [ModulePackage]
forall k a. Map k a -> [k]
M.keys [Map ModulePackage [ModuleLocation]]
pdbStates
	Level -> Text -> m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Format
"package-db-stack state: {} modules" Format -> Int -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ Set ModuleLocation -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Set ModuleLocation
packageDbMods
	(Watcher -> IO ()) -> m ()
forall (m :: * -> *). SessionMonad m => (Watcher -> IO ()) -> m ()
watch (\Watcher
w -> Watcher -> PackageDbStack -> [String] -> IO ()
watchPackageDbStack Watcher
w PackageDbStack
pdbs [String]
opts)

	[ModulePackage]
pkgs <- ([[ModulePackage]] -> [ModulePackage])
-> m [[ModulePackage]] -> m [ModulePackage]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[ModulePackage]] -> [ModulePackage]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (m [[ModulePackage]] -> m [ModulePackage])
-> m [[ModulePackage]] -> m [ModulePackage]
forall a b. (a -> b) -> a -> b
$ [PackageDb]
-> (PackageDb -> m [ModulePackage]) -> m [[ModulePackage]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (PackageDbStack -> [PackageDb]
packageDbs PackageDbStack
pdbs) ((PackageDb -> m [ModulePackage]) -> m [[ModulePackage]])
-> (PackageDb -> m [ModulePackage]) -> m [[ModulePackage]]
forall a b. (a -> b) -> a -> b
$ \PackageDb
pdb -> Query -> Only PackageDb -> m [ModulePackage]
forall q r (m :: * -> *).
(ToRow q, FromRow r, SessionMonad m) =>
Query -> q -> m [r]
SQLite.query Query
"select package_name, package_version from package_dbs where package_db == ?;" (PackageDb -> Only PackageDb
forall a. a -> Only a
SQLite.Only PackageDb
pdb)
	if [ModulePackage] -> Set ModulePackage
forall a. Ord a => [a] -> Set a
S.fromList [ModulePackage]
packages' Set ModulePackage -> Set ModulePackage -> Bool
forall a. Eq a => a -> a -> Bool
== [ModulePackage] -> Set ModulePackage
forall a. Ord a => [a] -> Set a
S.fromList [ModulePackage]
pkgs
		then Level -> Text -> m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace Text
"nothing changes, all packages the same"
		else do
			[ModuleLocation]
mlocs <- ([ModuleLocation] -> [ModuleLocation])
-> m [ModuleLocation] -> m [ModuleLocation]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
				((ModuleLocation -> Bool) -> [ModuleLocation] -> [ModuleLocation]
forall a. (a -> Bool) -> [a] -> [a]
filter (ModuleLocation -> Set ModuleLocation -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set ModuleLocation
packageDbMods)) (m [ModuleLocation] -> m [ModuleLocation])
-> m [ModuleLocation] -> m [ModuleLocation]
forall a b. (a -> b) -> a -> b
$
				(GhcM [ModuleLocation] -> m [ModuleLocation]
forall (m :: * -> *) a. SessionMonad m => GhcM a -> m a
inSessionGhc (GhcM [ModuleLocation] -> m [ModuleLocation])
-> GhcM [ModuleLocation] -> m [ModuleLocation]
forall a b. (a -> b) -> a -> b
$ [String]
-> PackageDbStack -> [ModulePackage] -> GhcM [ModuleLocation]
listModules [String]
opts PackageDbStack
pdbs [ModulePackage]
packages')
			let
				umlocs :: [ModuleLocation]
umlocs = [ModuleLocation] -> [ModuleLocation]
uniqueModuleLocations [ModuleLocation]
mlocs
			Level -> Text -> m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Format
"{} modules found, {} unique" Format -> Int -> Format
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ [ModuleLocation] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ModuleLocation]
mlocs Format -> Int -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ [ModuleLocation] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ModuleLocation]
umlocs
			let
				packageDbStackMods :: m [Only Int :. (ModuleLocation :. Inspection)]
packageDbStackMods = ([[Only Int :. (ModuleLocation :. Inspection)]]
 -> [Only Int :. (ModuleLocation :. Inspection)])
-> m [[Only Int :. (ModuleLocation :. Inspection)]]
-> m [Only Int :. (ModuleLocation :. Inspection)]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[Only Int :. (ModuleLocation :. Inspection)]]
-> [Only Int :. (ModuleLocation :. Inspection)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (m [[Only Int :. (ModuleLocation :. Inspection)]]
 -> m [Only Int :. (ModuleLocation :. Inspection)])
-> m [[Only Int :. (ModuleLocation :. Inspection)]]
-> m [Only Int :. (ModuleLocation :. Inspection)]
forall a b. (a -> b) -> a -> b
$ [PackageDb]
-> (PackageDb -> m [Only Int :. (ModuleLocation :. Inspection)])
-> m [[Only Int :. (ModuleLocation :. Inspection)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (PackageDbStack -> [PackageDb]
packageDbs PackageDbStack
pdbs) ((PackageDb -> m [Only Int :. (ModuleLocation :. Inspection)])
 -> m [[Only Int :. (ModuleLocation :. Inspection)]])
-> (PackageDb -> m [Only Int :. (ModuleLocation :. Inspection)])
-> m [[Only Int :. (ModuleLocation :. Inspection)]]
forall a b. (a -> b) -> a -> b
$ \PackageDb
pdb -> Query
-> Only PackageDb -> m [Only Int :. (ModuleLocation :. Inspection)]
forall q r (m :: * -> *).
(ToRow q, FromRow r, SessionMonad m) =>
Query -> q -> m [r]
SQLite.query 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 == ?;" (PackageDb -> Only PackageDb
forall a. a -> Only a
SQLite.Only PackageDb
pdb)
			m [Only Int :. (ModuleLocation :. Inspection)]
-> [ModuleToScan] -> [String] -> ([ModuleToScan] -> m ()) -> m ()
forall (m :: * -> *).
UpdateMonad m =>
m [Only Int :. (ModuleLocation :. Inspection)]
-> [ModuleToScan] -> [String] -> ([ModuleToScan] -> m ()) -> m ()
scan m [Only Int :. (ModuleLocation :. Inspection)]
packageDbStackMods ((,,) (ModuleLocation -> [String] -> Maybe Text -> ModuleToScan)
-> [ModuleLocation] -> [[String] -> Maybe Text -> ModuleToScan]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModuleLocation]
umlocs [[String] -> Maybe Text -> ModuleToScan]
-> [[String]] -> [Maybe Text -> ModuleToScan]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [String] -> [[String]]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [] [Maybe Text -> ModuleToScan] -> [Maybe Text] -> [ModuleToScan]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Text -> [Maybe Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing) [String]
opts (([ModuleToScan] -> m ()) -> m ())
-> ([ModuleToScan] -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \[ModuleToScan]
mlocs' -> do
				[InspectedModule]
ms <- GhcM [InspectedModule] -> m [InspectedModule]
forall (m :: * -> *) a. SessionMonad m => GhcM a -> m a
inSessionGhc (GhcM [InspectedModule] -> m [InspectedModule])
-> GhcM [InspectedModule] -> m [InspectedModule]
forall a b. (a -> b) -> a -> b
$ [String]
-> PackageDbStack -> [ModuleLocation] -> GhcM [InspectedModule]
browseModules [String]
opts PackageDbStack
pdbs ([ModuleToScan]
mlocs' [ModuleToScan]
-> Getting (Endo [ModuleLocation]) [ModuleToScan] ModuleLocation
-> [ModuleLocation]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. (ModuleToScan -> Const (Endo [ModuleLocation]) ModuleToScan)
-> [ModuleToScan] -> Const (Endo [ModuleLocation]) [ModuleToScan]
forall s t a b. Each s t a b => Traversal s t a b
each ((ModuleToScan -> Const (Endo [ModuleLocation]) ModuleToScan)
 -> [ModuleToScan] -> Const (Endo [ModuleLocation]) [ModuleToScan])
-> ((ModuleLocation
     -> Const (Endo [ModuleLocation]) ModuleLocation)
    -> ModuleToScan -> Const (Endo [ModuleLocation]) ModuleToScan)
-> Getting (Endo [ModuleLocation]) [ModuleToScan] ModuleLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleLocation -> Const (Endo [ModuleLocation]) ModuleLocation)
-> ModuleToScan -> Const (Endo [ModuleLocation]) ModuleToScan
forall s t a b. Field1 s t a b => Lens s t a b
_1)
				Level -> Text -> m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Format
"scanned {} modules" Format -> Int -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ [InspectedModule] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [InspectedModule]
ms
				ServerM IO () -> m ()
forall (m :: * -> *). UpdateMonad m => ServerM IO () -> m ()
sendUpdateAction (ServerM IO () -> m ()) -> ServerM IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> ServerM IO () -> ServerM IO ()
forall (m :: * -> *) a. MonadLog m => Text -> m a -> m a
timer Text
"updated package-db-stack modules" (ServerM IO () -> ServerM IO ()) -> ServerM IO () -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ do
					[InspectedModule] -> ServerM IO ()
forall (m :: * -> *). SessionMonad m => [InspectedModule] -> m ()
SQLite.updateModules [InspectedModule]
ms
					[ServerM IO ()] -> ServerM IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [PackageDb -> [ModulePackage] -> ServerM IO ()
forall (m :: * -> *).
SessionMonad m =>
PackageDb -> [ModulePackage] -> m ()
SQLite.updatePackageDb PackageDb
pdb (Map ModulePackage [ModuleLocation] -> [ModulePackage]
forall k a. Map k a -> [k]
M.keys Map ModulePackage [ModuleLocation]
pdbState) | (PackageDb
pdb, Map ModulePackage [ModuleLocation]
pdbState) <- [PackageDb]
-> [Map ModulePackage [ModuleLocation]]
-> [(PackageDb, Map ModulePackage [ModuleLocation])]
forall a b. [a] -> [b] -> [(a, b)]
zip (PackageDbStack -> [PackageDb]
packageDbs PackageDbStack
pdbs) [Map ModulePackage [ModuleLocation]]
pdbStates]

				-- BUG: I don't know why, but these steps leads to segfault on my PC:
				-- > hsdev scan --cabal --project .
				-- > hsdev check -f .\src\HsDev\Client\Commands.hs
				-- But it works if docs are scanned, it also works from ghci
				
				-- needDocs <- asks (view updateDocs)
				-- ms' <- if needDocs
				-- 	then do
				-- 		docs <- inSessionGhc $ hdocsCabal pdbs opts
				-- 		return $ map (fmap $ setDocs' docs) ms
				-- 	else return ms

				Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
hdocsSupported (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ [String] -> PackageDbStack -> m ()
forall (m :: * -> *).
UpdateMonad m =>
[String] -> PackageDbStack -> m ()
scanPackageDbStackDocs [String]
opts PackageDbStack
pdbs

				[ModuleLocation] -> m ()
forall (m :: * -> *). UpdateMonad m => [ModuleLocation] -> m ()
updater ([ModuleLocation] -> m ()) -> [ModuleLocation] -> m ()
forall a b. (a -> b) -> a -> b
$ [InspectedModule]
ms [InspectedModule]
-> Getting (Endo [ModuleLocation]) [InspectedModule] ModuleLocation
-> [ModuleLocation]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. (InspectedModule -> Const (Endo [ModuleLocation]) InspectedModule)
-> [InspectedModule]
-> Const (Endo [ModuleLocation]) [InspectedModule]
forall s t a b. Each s t a b => Traversal s t a b
each ((InspectedModule -> Const (Endo [ModuleLocation]) InspectedModule)
 -> [InspectedModule]
 -> Const (Endo [ModuleLocation]) [InspectedModule])
-> ((ModuleLocation
     -> Const (Endo [ModuleLocation]) ModuleLocation)
    -> InspectedModule
    -> Const (Endo [ModuleLocation]) InspectedModule)
-> Getting (Endo [ModuleLocation]) [InspectedModule] ModuleLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleLocation -> Const (Endo [ModuleLocation]) ModuleLocation)
-> InspectedModule -> Const (Endo [ModuleLocation]) InspectedModule
forall k1 t a k2. Lens (Inspected k1 t a) (Inspected k2 t a) k1 k2
inspectedKey

-- | Scan project file
scanProjectFile :: UpdateMonad m => [String] -> BuildTool -> Path -> m Project
scanProjectFile :: [String] -> BuildTool -> Text -> m Project
scanProjectFile [String]
opts BuildTool
tool Text
cabal = String -> Text -> m Project -> m Project
forall t (m :: * -> *) a.
(Display t, UpdateMonad m, NFData a) =>
String -> t -> m a -> m a
runTask String
"scanning" Text
cabal (m Project -> m Project) -> m Project -> m Project
forall a b. (a -> b) -> a -> b
$ do
	Project
proj <- (Project -> Project) -> m Project -> m Project
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((BuildTool -> Identity BuildTool) -> Project -> Identity Project)
-> BuildTool -> Project -> Project
forall s t a b. ASetter s t a b -> b -> s -> t
set (BuildTool -> Identity BuildTool) -> Project -> Identity Project
Lens' Project BuildTool
projectBuildTool BuildTool
tool) (m Project -> m Project) -> m Project -> m Project
forall a b. (a -> b) -> a -> b
$ [String] -> Text -> m Project
forall (m :: * -> *).
CommandMonad m =>
[String] -> Text -> m Project
S.scanProjectFile [String]
opts Text
cabal
	PackageDbStack
pdbs <- GhcM PackageDbStack -> m PackageDbStack
forall (m :: * -> *) a. SessionMonad m => GhcM a -> m a
inSessionGhc (GhcM PackageDbStack -> m PackageDbStack)
-> GhcM PackageDbStack -> m PackageDbStack
forall a b. (a -> b) -> a -> b
$ Project -> GhcM PackageDbStack
getProjectPackageDbStack Project
proj
	let
		proj' :: Project
proj' = ASetter
  Project Project (Maybe PackageDbStack) (Maybe PackageDbStack)
-> Maybe PackageDbStack -> Project -> Project
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  Project Project (Maybe PackageDbStack) (Maybe PackageDbStack)
Lens' Project (Maybe PackageDbStack)
projectPackageDbStack (PackageDbStack -> Maybe PackageDbStack
forall a. a -> Maybe a
Just PackageDbStack
pdbs) Project
proj
	ServerM IO () -> m ()
forall (m :: * -> *). UpdateMonad m => ServerM IO () -> m ()
sendUpdateAction (ServerM IO () -> m ()) -> ServerM IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> ServerM IO () -> ServerM IO ()
forall (m :: * -> *) a.
(MonadLog m, HasCallStack) =>
Text -> m a -> m a
Log.scope Text
"scan-project-file" (ServerM IO () -> ServerM IO ()) -> ServerM IO () -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ Project -> ServerM IO ()
forall (m :: * -> *). SessionMonad m => Project -> m ()
SQLite.updateProject Project
proj'
	Project -> m Project
forall (m :: * -> *) a. Monad m => a -> m a
return Project
proj'

-- | Refine project info and update if necessary
refineProjectInfo :: UpdateMonad m => Project -> m Project
refineProjectInfo :: Project -> m Project
refineProjectInfo Project
proj = do
	[SQLite.Only Bool
exist] <- Query -> Only Text -> m [Only Bool]
forall q r (m :: * -> *).
(ToRow q, FromRow r, SessionMonad m) =>
Query -> q -> m [r]
SQLite.query Query
"select count(*) > 0 from projects where cabal == ?;" (Text -> Only Text
forall a. a -> Only a
SQLite.Only (Project
proj Project -> Getting Text Project Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text Project Text
Lens' Project Text
projectCabal))
	if Bool
exist
		then Text -> m Project
forall (m :: * -> *). SessionMonad m => Text -> m Project
SQLite.loadProject (Project
proj Project -> Getting Text Project Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text Project Text
Lens' Project Text
projectCabal)
		else String -> Text -> m Project -> m Project
forall t (m :: * -> *) a.
(Display t, UpdateMonad m, NFData a) =>
String -> t -> m a -> m a
runTask String
"scanning" (Project
proj Project -> Getting Text Project Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text Project Text
Lens' Project Text
projectCabal) (m Project -> m Project) -> m Project -> m Project
forall a b. (a -> b) -> a -> b
$ do
			Project
proj' <- IO Project -> m Project
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Project -> m Project) -> IO Project -> m Project
forall a b. (a -> b) -> a -> b
$ Project -> IO Project
loadProject Project
proj
			PackageDbStack
pdbs <- GhcM PackageDbStack -> m PackageDbStack
forall (m :: * -> *) a. SessionMonad m => GhcM a -> m a
inSessionGhc (GhcM PackageDbStack -> m PackageDbStack)
-> GhcM PackageDbStack -> m PackageDbStack
forall a b. (a -> b) -> a -> b
$ Project -> GhcM PackageDbStack
getProjectPackageDbStack Project
proj'
			let
				proj'' :: Project
proj'' = ASetter
  Project Project (Maybe PackageDbStack) (Maybe PackageDbStack)
-> Maybe PackageDbStack -> Project -> Project
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  Project Project (Maybe PackageDbStack) (Maybe PackageDbStack)
Lens' Project (Maybe PackageDbStack)
projectPackageDbStack (PackageDbStack -> Maybe PackageDbStack
forall a. a -> Maybe a
Just PackageDbStack
pdbs) Project
proj'
			ServerM IO () -> m ()
forall (m :: * -> *). UpdateMonad m => ServerM IO () -> m ()
sendUpdateAction (ServerM IO () -> m ()) -> ServerM IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> ServerM IO () -> ServerM IO ()
forall (m :: * -> *) a.
(MonadLog m, HasCallStack) =>
Text -> m a -> m a
Log.scope Text
"refine-project-info" (ServerM IO () -> ServerM IO ()) -> ServerM IO () -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ Project -> ServerM IO ()
forall (m :: * -> *). SessionMonad m => Project -> m ()
SQLite.updateProject Project
proj''
			Project -> m Project
forall (m :: * -> *) a. Monad m => a -> m a
return Project
proj''

-- | Get project info for module
locateProjectInfo :: UpdateMonad m => Path -> m (Maybe Project)
locateProjectInfo :: Text -> m (Maybe Project)
locateProjectInfo Text
cabal = IO (Maybe Project) -> m (Maybe Project)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO (Maybe Project)
locateProject (((String -> Const String String) -> Text -> Const String Text)
-> Text -> String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (String -> Const String String) -> Text -> Const String Text
Lens' Text String
path Text
cabal)) m (Maybe Project)
-> (Maybe Project -> m (Maybe Project)) -> m (Maybe Project)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Project -> m Project) -> Maybe Project -> m (Maybe Project)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Project -> m Project
forall (m :: * -> *). UpdateMonad m => Project -> m Project
refineProjectInfo

-- | Scan project and related package-db stack
scanProjectStack :: UpdateMonad m => [String] -> BuildTool -> Path -> m ()
scanProjectStack :: [String] -> BuildTool -> Text -> m ()
scanProjectStack [String]
opts BuildTool
tool Text
cabal = do
	Maybe Sandbox
sbox <- IO (Maybe Sandbox) -> m (Maybe Sandbox)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Sandbox) -> m (Maybe Sandbox))
-> IO (Maybe Sandbox) -> m (Maybe Sandbox)
forall a b. (a -> b) -> a -> b
$ BuildTool -> Text -> IO (Maybe Sandbox)
projectSandbox BuildTool
tool Text
cabal
	m () -> (Sandbox -> m ()) -> Maybe Sandbox -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([String] -> m ()
forall (m :: * -> *). UpdateMonad m => [String] -> m ()
scanCabal [String]
opts) ([String] -> Sandbox -> m ()
forall (m :: * -> *). UpdateMonad m => [String] -> Sandbox -> m ()
scanSandbox [String]
opts) Maybe Sandbox
sbox
	[String] -> BuildTool -> Text -> m ()
forall (m :: * -> *).
UpdateMonad m =>
[String] -> BuildTool -> Text -> m ()
scanProject [String]
opts BuildTool
tool Text
cabal

-- | Scan project
scanProject :: UpdateMonad m => [String] -> BuildTool -> Path -> m ()
scanProject :: [String] -> BuildTool -> Text -> m ()
scanProject [String]
opts BuildTool
tool Text
cabal = String -> Project -> m () -> m ()
forall t (m :: * -> *) a.
(Display t, UpdateMonad m, NFData a) =>
String -> t -> m a -> m a
runTask String
"scanning" (String -> Project
project (String -> Project) -> String -> Project
forall a b. (a -> b) -> a -> b
$ ((String -> Const String String) -> Text -> Const String Text)
-> Text -> String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (String -> Const String String) -> Text -> Const String Text
Lens' Text String
path Text
cabal) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> m () -> m ()
forall (m :: * -> *) a.
(MonadLog m, HasCallStack) =>
Text -> m a -> m a
Log.scope Text
"project" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
	Project
proj <- [String] -> BuildTool -> Text -> m Project
forall (m :: * -> *).
UpdateMonad m =>
[String] -> BuildTool -> Text -> m Project
scanProjectFile [String]
opts BuildTool
tool Text
cabal
	(Watcher -> IO ()) -> m ()
forall (m :: * -> *). SessionMonad m => (Watcher -> IO ()) -> m ()
watch (\Watcher
w -> Watcher -> Project -> [String] -> IO ()
watchProject Watcher
w Project
proj [String]
opts)
	S.ScanContents [ModuleToScan]
_ [(Project
_, [ModuleToScan]
sources)] [PackageDbStack]
_ <- Project -> m ScanContents
forall (m :: * -> *). CommandMonad m => Project -> m ScanContents
S.enumProject Project
proj
	let
		projMods :: m [Only Int :. (ModuleLocation :. Inspection)]
projMods = Query
-> Only Text -> m [Only Int :. (ModuleLocation :. Inspection)]
forall q r (m :: * -> *).
(ToRow q, FromRow r, SessionMonad m) =>
Query -> q -> m [r]
SQLite.query 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 == ?;" (Text -> Only Text
forall a. a -> Only a
SQLite.Only (Text -> Only Text) -> Text -> Only Text
forall a b. (a -> b) -> a -> b
$ Project
proj Project -> Getting Text Project Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text Project Text
Lens' Project Text
projectCabal)
	m [Only Int :. (ModuleLocation :. Inspection)]
-> [ModuleToScan] -> [String] -> ([ModuleToScan] -> m ()) -> m ()
forall (m :: * -> *).
UpdateMonad m =>
m [Only Int :. (ModuleLocation :. Inspection)]
-> [ModuleToScan] -> [String] -> ([ModuleToScan] -> m ()) -> m ()
scan m [Only Int :. (ModuleLocation :. Inspection)]
projMods [ModuleToScan]
sources [String]
opts (([ModuleToScan] -> m ()) -> m ())
-> ([ModuleToScan] -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ [String] -> [ModuleToScan] -> m ()
forall (m :: * -> *).
UpdateMonad m =>
[String] -> [ModuleToScan] -> m ()
scanModules [String]
opts

		-- Scan docs
		-- inSessionGhc $ do
		-- 	currentSession >>= maybe (return ()) (const clearTargets)

		-- 	forM_ (maybe [] targetInfos (proj ^. projectDescription)) $ \tinfo' -> do
		-- 		opts' <- getProjectTargetOpts [] proj (tinfo' ^. targetBuildInfo)
		-- 		files' <- projectTargetFiles proj tinfo'
		-- 		haddockSession opts'
		-- 		docsMap <- liftGhc $ readProjectTargetDocs opts' proj files'
		-- 		Log.sendLog Log.Debug $ "scanned logs for modules: {}, summary docs: {}" ~~ (intercalate "," (M.keys docsMap)) ~~ (sum $ map M.size $ M.elems docsMap)


-- | Scan directory for source files and projects
scanDirectory :: UpdateMonad m => [String] -> Path -> m ()
scanDirectory :: [String] -> Text -> m ()
scanDirectory [String]
opts Text
dir = String -> Text -> m () -> m ()
forall t (m :: * -> *) a.
(Display t, UpdateMonad m, NFData a) =>
String -> t -> m a -> m a
runTask String
"scanning" Text
dir (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> m () -> m ()
forall (m :: * -> *) a.
(MonadLog m, HasCallStack) =>
Text -> m a -> m a
Log.scope Text
"directory" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
	S.ScanContents [ModuleToScan]
standSrcs [ProjectToScan]
projSrcs [PackageDbStack]
pdbss <- String -> m ScanContents
forall (m :: * -> *). CommandMonad m => String -> m ScanContents
S.enumDirectory (((String -> Const String String) -> Text -> Const String Text)
-> Text -> String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (String -> Const String String) -> Text -> Const String Text
Lens' Text String
path Text
dir)
	[m ()] -> m ()
forall (m :: * -> *). UpdateMonad m => [m ()] -> m ()
runTasks_ [[String] -> BuildTool -> Text -> m ()
forall (m :: * -> *).
UpdateMonad m =>
[String] -> BuildTool -> Text -> m ()
scanProject [String]
opts BuildTool
CabalTool (Getting Text Project Text -> Project -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text Project Text
Lens' Project Text
projectCabal Project
p) | (Project
p, [ModuleToScan]
_) <- [ProjectToScan]
projSrcs]
	[m ()] -> m ()
forall (m :: * -> *). UpdateMonad m => [m ()] -> m ()
runTasks_ ([m ()] -> m ()) -> [m ()] -> m ()
forall a b. (a -> b) -> a -> b
$ (PackageDbStack -> m ()) -> [PackageDbStack] -> [m ()]
forall a b. (a -> b) -> [a] -> [b]
map ([String] -> PackageDbStack -> m ()
forall (m :: * -> *).
UpdateMonad m =>
[String] -> PackageDbStack -> m ()
scanPackageDb [String]
opts) [PackageDbStack]
pdbss -- TODO: Don't rescan
	Getting (Sequenced () m) [ModuleToScan] ModuleLocation
-> (ModuleLocation -> m ()) -> [ModuleToScan] -> m ()
forall (m :: * -> *) r s a.
Monad m =>
Getting (Sequenced r m) s a -> (a -> m r) -> s -> m ()
mapMOf_ ((ModuleToScan -> Const (Sequenced () m) ModuleToScan)
-> [ModuleToScan] -> Const (Sequenced () m) [ModuleToScan]
forall s t a b. Each s t a b => Traversal s t a b
each ((ModuleToScan -> Const (Sequenced () m) ModuleToScan)
 -> [ModuleToScan] -> Const (Sequenced () m) [ModuleToScan])
-> ((ModuleLocation -> Const (Sequenced () m) ModuleLocation)
    -> ModuleToScan -> Const (Sequenced () m) ModuleToScan)
-> Getting (Sequenced () m) [ModuleToScan] ModuleLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleLocation -> Const (Sequenced () m) ModuleLocation)
-> ModuleToScan -> Const (Sequenced () m) ModuleToScan
forall s t a b. Field1 s t a b => Lens s t a b
_1) ((Watcher -> IO ()) -> m ()
forall (m :: * -> *). SessionMonad m => (Watcher -> IO ()) -> m ()
watch ((Watcher -> IO ()) -> m ())
-> (ModuleLocation -> Watcher -> IO ()) -> ModuleLocation -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Watcher -> ModuleLocation -> IO ())
-> ModuleLocation -> Watcher -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Watcher -> ModuleLocation -> IO ()
watchModule) [ModuleToScan]
standSrcs
	let
		standaloneMods :: m [Only Int :. (ModuleLocation :. Inspection)]
standaloneMods = Query
-> Only Text -> m [Only Int :. (ModuleLocation :. Inspection)]
forall q r (m :: * -> *).
(ToRow q, FromRow r, SessionMonad m) =>
Query -> q -> m [r]
SQLite.query 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 '\\';" (Text -> Only Text
forall a. a -> Only a
SQLite.Only (Text -> Only Text) -> Text -> Only Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
SQLite.escapeLike Text
dir Text -> Text -> Text
`T.append` Text
"%")
	m [Only Int :. (ModuleLocation :. Inspection)]
-> [ModuleToScan] -> [String] -> ([ModuleToScan] -> m ()) -> m ()
forall (m :: * -> *).
UpdateMonad m =>
m [Only Int :. (ModuleLocation :. Inspection)]
-> [ModuleToScan] -> [String] -> ([ModuleToScan] -> m ()) -> m ()
scan m [Only Int :. (ModuleLocation :. Inspection)]
standaloneMods [ModuleToScan]
standSrcs [String]
opts (([ModuleToScan] -> m ()) -> m ())
-> ([ModuleToScan] -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ [String] -> [ModuleToScan] -> m ()
forall (m :: * -> *).
UpdateMonad m =>
[String] -> [ModuleToScan] -> m ()
scanModules [String]
opts

-- | Scan installed docs
scanPackageDbStackDocs :: UpdateMonad m => [String] -> PackageDbStack -> m ()
scanPackageDbStackDocs :: [String] -> PackageDbStack -> m ()
scanPackageDbStackDocs [String]
opts PackageDbStack
pdbs
	| Bool
hdocsSupported = Text -> m () -> m ()
forall (m :: * -> *) a.
(MonadLog m, HasCallStack) =>
Text -> m a -> m a
Log.scope Text
"docs" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
		[(ModulePackage, Map Text (Map Text Text))]
docs <- GhcM [(ModulePackage, Map Text (Map Text Text))]
-> m [(ModulePackage, Map Text (Map Text Text))]
forall (m :: * -> *) a. SessionMonad m => GhcM a -> m a
inSessionGhc (GhcM [(ModulePackage, Map Text (Map Text Text))]
 -> m [(ModulePackage, Map Text (Map Text Text))])
-> GhcM [(ModulePackage, Map Text (Map Text Text))]
-> m [(ModulePackage, Map Text (Map Text Text))]
forall a b. (a -> b) -> a -> b
$ PackageDbStack
-> [String] -> GhcM [(ModulePackage, Map Text (Map Text Text))]
hdocsCabal PackageDbStack
pdbs [String]
opts
		Level -> Text -> m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Format
"docs scanned: {} packages, {} modules total"
			Format -> Int -> Format
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ [(ModulePackage, Map Text (Map Text Text))] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(ModulePackage, Map Text (Map Text Text))]
docs Format -> Int -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (((ModulePackage, Map Text (Map Text Text)) -> Int)
-> [(ModulePackage, Map Text (Map Text Text))] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Map Text (Map Text Text) -> Int
forall k a. Map k a -> Int
M.size (Map Text (Map Text Text) -> Int)
-> ((ModulePackage, Map Text (Map Text Text))
    -> Map Text (Map Text Text))
-> (ModulePackage, Map Text (Map Text Text))
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModulePackage, Map Text (Map Text Text))
-> Map Text (Map Text Text)
forall a b. (a, b) -> b
snd) [(ModulePackage, Map Text (Map Text Text))]
docs)
		ServerM IO () -> m ()
forall (m :: * -> *). UpdateMonad m => ServerM IO () -> m ()
sendUpdateAction (ServerM IO () -> m ()) -> ServerM IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ServerM IO () -> ServerM IO ()
forall (m :: * -> *) a. SessionMonad m => m a -> m a
transact (ServerM IO () -> ServerM IO ()) -> ServerM IO () -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ Query -> [(Text, Text, Text, Text, Text)] -> ServerM IO ()
forall q (m :: * -> *).
(ToRow q, SessionMonad m) =>
Query -> [q] -> m ()
SQLite.executeMany Query
"update symbols set docs = ? where name == ? and module_id in (select id from modules where name == ? and package_name == ? and package_version == ?);" ([(Text, Text, Text, Text, Text)] -> ServerM IO ())
-> [(Text, Text, Text, Text, Text)] -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ do
			(ModulePackage Text
pname Text
pver, Map Text (Map Text Text)
pdocs) <- [(ModulePackage, Map Text (Map Text Text))]
docs
			(Text
mname, Map Text Text
mdocs) <- Map Text (Map Text Text) -> [(Text, Map Text Text)]
forall k a. Map k a -> [(k, a)]
M.toList Map Text (Map Text Text)
pdocs
			(Text
nm, Text
doc) <- Map Text Text -> [(Text, Text)]
forall k a. Map k a -> [(k, a)]
M.toList Map Text Text
mdocs
			(Text, Text, Text, Text, Text) -> [(Text, Text, Text, Text, Text)]
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
doc, Text
nm, Text
mname, Text
pname, Text
pver)
		Level -> Text -> m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace Text
"docs set"
	| Bool
otherwise = Level -> Text -> m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Warning Text
"hdocs not supported"

-- | Scan docs for inspected modules
scanDocs :: UpdateMonad m => [Module] -> m ()
scanDocs :: [Module] -> m ()
scanDocs
	| Bool
hdocsSupported = [m ()] -> m ()
forall (m :: * -> *). UpdateMonad m => [m ()] -> m ()
runTasks_ ([m ()] -> m ()) -> ([Module] -> [m ()]) -> [Module] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Module -> m ()) -> [Module] -> [m ()]
forall a b. (a -> b) -> [a] -> [b]
map Module -> m ()
forall (m :: * -> *).
(CommandMonad m, MonadReader UpdateState m,
 MonadWriter [ModuleLocation] m) =>
Module -> m ()
scanDocs'
	| Bool
otherwise = m () -> [Module] -> m ()
forall a b. a -> b -> a
const (m () -> [Module] -> m ()) -> m () -> [Module] -> m ()
forall a b. (a -> b) -> a -> b
$ Level -> Text -> m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Warning Text
"hdocs not supported"
	where
		scanDocs' :: Module -> m ()
scanDocs' Module
m = String -> ModuleLocation -> m () -> m ()
forall t (m :: * -> *) a.
(Display t, UpdateMonad m, NFData a) =>
String -> t -> m a -> m a
runTask String
"scanning docs" (Getting ModuleLocation Module ModuleLocation
-> Module -> ModuleLocation
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((ModuleId -> Const ModuleLocation ModuleId)
-> Module -> Const ModuleLocation Module
Lens' Module ModuleId
moduleId ((ModuleId -> Const ModuleLocation ModuleId)
 -> Module -> Const ModuleLocation Module)
-> ((ModuleLocation -> Const ModuleLocation ModuleLocation)
    -> ModuleId -> Const ModuleLocation ModuleId)
-> Getting ModuleLocation Module ModuleLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleLocation -> Const ModuleLocation ModuleLocation)
-> ModuleId -> Const ModuleLocation ModuleId
Lens' ModuleId ModuleLocation
moduleLocation) Module
m) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> m () -> m ()
forall (m :: * -> *) a.
(MonadLog m, HasCallStack) =>
Text -> m a -> m a
Log.scope Text
"docs" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
			Maybe Int
mid <- ModuleId -> m (Maybe Int)
forall (m :: * -> *). SessionMonad m => ModuleId -> m (Maybe Int)
SQLite.lookupModule (Module
m Module -> Getting ModuleId Module ModuleId -> ModuleId
forall s a. s -> Getting a s a -> a
^. Getting ModuleId Module ModuleId
Lens' Module ModuleId
moduleId)
			Int
mid' <- m Int -> (Int -> m Int) -> Maybe Int -> m Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (HsDevError -> m Int
forall (m :: * -> *) a. MonadThrow m => HsDevError -> m a
hsdevError (HsDevError -> m Int) -> HsDevError -> m Int
forall a b. (a -> b) -> a -> b
$ String -> HsDevError
SQLiteError String
"module id not found") Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int
mid
			Module
m' <- LensLike (WrappedMonad m) Module Module Project Project
-> (Project -> m Project) -> Module -> m Module
forall (m :: * -> *) s t a b.
LensLike (WrappedMonad m) s t a b -> (a -> m b) -> s -> m t
mapMOf ((ModuleId -> WrappedMonad m ModuleId)
-> Module -> WrappedMonad m Module
Lens' Module ModuleId
moduleId ((ModuleId -> WrappedMonad m ModuleId)
 -> Module -> WrappedMonad m Module)
-> ((Project -> WrappedMonad m Project)
    -> ModuleId -> WrappedMonad m ModuleId)
-> LensLike (WrappedMonad m) Module Module Project Project
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleLocation -> WrappedMonad m ModuleLocation)
-> ModuleId -> WrappedMonad m ModuleId
Lens' ModuleId ModuleLocation
moduleLocation ((ModuleLocation -> WrappedMonad m ModuleLocation)
 -> ModuleId -> WrappedMonad m ModuleId)
-> ((Project -> WrappedMonad m Project)
    -> ModuleLocation -> WrappedMonad m ModuleLocation)
-> (Project -> WrappedMonad m Project)
-> ModuleId
-> WrappedMonad m ModuleId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Project -> WrappedMonad m (Maybe Project))
-> ModuleLocation -> WrappedMonad m ModuleLocation
Traversal' ModuleLocation (Maybe Project)
moduleProject ((Maybe Project -> WrappedMonad m (Maybe Project))
 -> ModuleLocation -> WrappedMonad m ModuleLocation)
-> ((Project -> WrappedMonad m Project)
    -> Maybe Project -> WrappedMonad m (Maybe Project))
-> (Project -> WrappedMonad m Project)
-> ModuleLocation
-> WrappedMonad m ModuleLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Project -> WrappedMonad m Project)
-> Maybe Project -> WrappedMonad m (Maybe Project)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just) Project -> m Project
forall (m :: * -> *). UpdateMonad m => Project -> m Project
refineProjectInfo Module
m
			Level -> Text -> m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Format
"Scanning docs for {}" Format -> ModuleLocation -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ Getting ModuleLocation Module ModuleLocation
-> Module -> ModuleLocation
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((ModuleId -> Const ModuleLocation ModuleId)
-> Module -> Const ModuleLocation Module
Lens' Module ModuleId
moduleId ((ModuleId -> Const ModuleLocation ModuleId)
 -> Module -> Const ModuleLocation Module)
-> ((ModuleLocation -> Const ModuleLocation ModuleLocation)
    -> ModuleId -> Const ModuleLocation ModuleId)
-> Getting ModuleLocation Module ModuleLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleLocation -> Const ModuleLocation ModuleLocation)
-> ModuleId -> Const ModuleLocation ModuleId
Lens' ModuleId ModuleLocation
moduleLocation) Module
m'
			Maybe (Map String String)
docsMap <- GhcM (Maybe (Map String String)) -> m (Maybe (Map String String))
forall (m :: * -> *) a. SessionMonad m => GhcM a -> m a
inSessionGhc (GhcM (Maybe (Map String String)) -> m (Maybe (Map String String)))
-> GhcM (Maybe (Map String String))
-> m (Maybe (Map String String))
forall a b. (a -> b) -> a -> b
$ do
				(PackageDbStack
pdbs, [String]
opts') <- [String] -> Module -> GhcM (PackageDbStack, [String])
getModuleOpts [] Module
m'
				MGhcT
  SessionConfig
  (First DynFlags)
  (LogT IO)
  (Maybe (Session SessionConfig (First DynFlags)))
forall (m :: * -> *) s d.
MonadIO m =>
MGhcT s d m (Maybe (Session s d))
currentSession MGhcT
  SessionConfig
  (First DynFlags)
  (LogT IO)
  (Maybe (Session SessionConfig (First DynFlags)))
-> (Maybe (Session SessionConfig (First DynFlags)) -> GhcM ())
-> GhcM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GhcM ()
-> (Session SessionConfig (First DynFlags) -> GhcM ())
-> Maybe (Session SessionConfig (First DynFlags))
-> GhcM ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> GhcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (GhcM () -> Session SessionConfig (First DynFlags) -> GhcM ()
forall a b. a -> b -> a
const GhcM ()
forall (m :: * -> *). GhcMonad m => m ()
clearTargets)
				-- Calling haddock with targets set sometimes cause errors
				PackageDbStack -> [String] -> GhcM ()
haddockSession PackageDbStack
pdbs [String]
opts'
				[String] -> Module -> GhcM (Maybe (Map String String))
readModuleDocs [String]
opts' Module
m'
			ServerM IO () -> m ()
forall (m :: * -> *). UpdateMonad m => ServerM IO () -> m ()
sendUpdateAction (ServerM IO () -> m ()) -> ServerM IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ServerM IO () -> ServerM IO ()
forall (m :: * -> *) a. SessionMonad m => m a -> m a
transact (ServerM IO () -> ServerM IO ()) -> ServerM IO () -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ do
				Query -> [(String, String, Int)] -> ServerM IO ()
forall q (m :: * -> *).
(ToRow q, SessionMonad m) =>
Query -> [q] -> m ()
SQLite.executeMany Query
"update symbols set docs = ? where name == ? and module_id == ?;"
					[(String
doc, String
nm, Int
mid') | (String
nm, String
doc) <- [(String, String)]
-> (Map String String -> [(String, String)])
-> Maybe (Map String String)
-> [(String, String)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Map String String -> [(String, String)]
forall k a. Map k a -> [(k, a)]
M.toList Maybe (Map String String)
docsMap]
				Query -> Only Int -> ServerM IO ()
forall q (m :: * -> *).
(ToRow q, SessionMonad m) =>
Query -> q -> m ()
SQLite.execute Query
"update modules set tags = json_set(tags, '$.docs', 1) where id == ?;" (Int -> Only Int
forall a. a -> Only a
SQLite.Only Int
mid')

-- | Set inferred types for module
setModTypes :: UpdateMonad m => ModuleId -> [Note TypedExpr] -> m ()
setModTypes :: ModuleId -> [Note TypedExpr] -> m ()
setModTypes ModuleId
m [Note TypedExpr]
ts = Text -> m () -> m ()
forall (m :: * -> *) a.
(MonadLog m, HasCallStack) =>
Text -> m a -> m a
Log.scope Text
"set-types" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
	Maybe Int
mid <- ModuleId -> m (Maybe Int)
forall (m :: * -> *). SessionMonad m => ModuleId -> m (Maybe Int)
SQLite.lookupModule ModuleId
m
	Int
mid' <- m Int -> (Int -> m Int) -> Maybe Int -> m Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (HsDevError -> m Int
forall (m :: * -> *) a. MonadThrow m => HsDevError -> m a
hsdevError (HsDevError -> m Int) -> HsDevError -> m Int
forall a b. (a -> b) -> a -> b
$ String -> HsDevError
SQLiteError String
"module id not found") Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int
mid
	ServerM IO () -> m ()
forall (m :: * -> *). UpdateMonad m => ServerM IO () -> m ()
sendUpdateAction (ServerM IO () -> m ()) -> ServerM IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ServerM IO () -> ServerM IO ()
forall (m :: * -> *) a. SessionMonad m => m a -> m a
transact (ServerM IO () -> ServerM IO ()) -> ServerM IO () -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ do
		Query -> Only Int -> ServerM IO ()
forall q (m :: * -> *).
(ToRow q, SessionMonad m) =>
Query -> q -> m ()
SQLite.execute Query
"delete from types where module_id = ?;" (Int -> Only Int
forall a. a -> Only a
SQLite.Only Int
mid')
		Query -> [Only Int :. (Region :. TypedExpr)] -> ServerM IO ()
forall q (m :: * -> *).
(ToRow q, SessionMonad m) =>
Query -> [q] -> m ()
SQLite.executeMany Query
"insert into types (module_id, line, column, line_to, column_to, expr, type) values (?, ?, ?, ?, ?, ?, ?);" [
			(Int -> Only Int
forall a. a -> Only a
SQLite.Only Int
mid' Only Int
-> (Region :. TypedExpr) -> Only Int :. (Region :. TypedExpr)
forall h t. h -> t -> h :. t
SQLite.:. Getting Region (Note TypedExpr) Region -> Note TypedExpr -> Region
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Region (Note TypedExpr) Region
forall a. Lens' (Note a) Region
noteRegion Note TypedExpr
n' Region -> TypedExpr -> Region :. TypedExpr
forall h t. h -> t -> h :. t
SQLite.:. Getting TypedExpr (Note TypedExpr) TypedExpr
-> Note TypedExpr -> TypedExpr
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting TypedExpr (Note TypedExpr) TypedExpr
forall a a2. Lens (Note a) (Note a2) a a2
note Note TypedExpr
n') | Note TypedExpr
n' <- (Note TypedExpr -> Region) -> [Note TypedExpr] -> [Note TypedExpr]
forall b a. Ord b => (a -> b) -> [a] -> [a]
uniqueBy (Getting Region (Note TypedExpr) Region -> Note TypedExpr -> Region
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Region (Note TypedExpr) Region
forall a. Lens' (Note a) Region
noteRegion) [Note TypedExpr]
ts]
		Query -> (Int, Int) -> ServerM IO ()
forall q (m :: * -> *).
(ToRow q, SessionMonad m) =>
Query -> q -> m ()
SQLite.execute Query
"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 == ?;"
			(Int
mid', Int
mid')
		Query -> (Int, Int) -> ServerM IO ()
forall q (m :: * -> *).
(ToRow q, SessionMonad m) =>
Query -> q -> m ()
SQLite.execute Query
"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;" (Int
mid', Int
mid')
		Query -> Only Int -> ServerM IO ()
forall q (m :: * -> *).
(ToRow q, SessionMonad m) =>
Query -> q -> m ()
SQLite.execute Query
"update modules set tags = json_set(tags, '$.types', 1) where id == ?;" (Int -> Only Int
forall a. a -> Only a
SQLite.Only Int
mid')

-- | Infer types for modules
inferModTypes :: UpdateMonad m => [Module] -> m ()
inferModTypes :: [Module] -> m ()
inferModTypes = [m ()] -> m ()
forall (m :: * -> *). UpdateMonad m => [m ()] -> m ()
runTasks_ ([m ()] -> m ()) -> ([Module] -> [m ()]) -> [Module] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Module -> m ()) -> [Module] -> [m ()]
forall a b. (a -> b) -> [a] -> [b]
map Module -> m ()
forall (m :: * -> *).
(CommandMonad m, MonadReader UpdateState m,
 MonadWriter [ModuleLocation] m) =>
Module -> m ()
inferModTypes' where
	inferModTypes' :: Module -> m ()
inferModTypes' Module
m = String -> ModuleLocation -> m () -> m ()
forall t (m :: * -> *) a.
(Display t, UpdateMonad m, NFData a) =>
String -> t -> m a -> m a
runTask String
"inferring types" (Getting ModuleLocation Module ModuleLocation
-> Module -> ModuleLocation
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((ModuleId -> Const ModuleLocation ModuleId)
-> Module -> Const ModuleLocation Module
Lens' Module ModuleId
moduleId ((ModuleId -> Const ModuleLocation ModuleId)
 -> Module -> Const ModuleLocation Module)
-> ((ModuleLocation -> Const ModuleLocation ModuleLocation)
    -> ModuleId -> Const ModuleLocation ModuleId)
-> Getting ModuleLocation Module ModuleLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleLocation -> Const ModuleLocation ModuleLocation)
-> ModuleId -> Const ModuleLocation ModuleId
Lens' ModuleId ModuleLocation
moduleLocation) Module
m) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> m () -> m ()
forall (m :: * -> *) a.
(MonadLog m, HasCallStack) =>
Text -> m a -> m a
Log.scope Text
"types" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
		Maybe Int
mid <- ModuleId -> m (Maybe Int)
forall (m :: * -> *). SessionMonad m => ModuleId -> m (Maybe Int)
SQLite.lookupModule (Module
m Module -> Getting ModuleId Module ModuleId -> ModuleId
forall s a. s -> Getting a s a -> a
^. Getting ModuleId Module ModuleId
Lens' Module ModuleId
moduleId)
		Int
_ <- m Int -> (Int -> m Int) -> Maybe Int -> m Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (HsDevError -> m Int
forall (m :: * -> *) a. MonadThrow m => HsDevError -> m a
hsdevError (HsDevError -> m Int) -> HsDevError -> m Int
forall a b. (a -> b) -> a -> b
$ String -> HsDevError
SQLiteError String
"module id not found") Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int
mid
		Module
m' <- LensLike (WrappedMonad m) Module Module Project Project
-> (Project -> m Project) -> Module -> m Module
forall (m :: * -> *) s t a b.
LensLike (WrappedMonad m) s t a b -> (a -> m b) -> s -> m t
mapMOf ((ModuleId -> WrappedMonad m ModuleId)
-> Module -> WrappedMonad m Module
Lens' Module ModuleId
moduleId ((ModuleId -> WrappedMonad m ModuleId)
 -> Module -> WrappedMonad m Module)
-> ((Project -> WrappedMonad m Project)
    -> ModuleId -> WrappedMonad m ModuleId)
-> LensLike (WrappedMonad m) Module Module Project Project
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleLocation -> WrappedMonad m ModuleLocation)
-> ModuleId -> WrappedMonad m ModuleId
Lens' ModuleId ModuleLocation
moduleLocation ((ModuleLocation -> WrappedMonad m ModuleLocation)
 -> ModuleId -> WrappedMonad m ModuleId)
-> ((Project -> WrappedMonad m Project)
    -> ModuleLocation -> WrappedMonad m ModuleLocation)
-> (Project -> WrappedMonad m Project)
-> ModuleId
-> WrappedMonad m ModuleId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Project -> WrappedMonad m (Maybe Project))
-> ModuleLocation -> WrappedMonad m ModuleLocation
Traversal' ModuleLocation (Maybe Project)
moduleProject ((Maybe Project -> WrappedMonad m (Maybe Project))
 -> ModuleLocation -> WrappedMonad m ModuleLocation)
-> ((Project -> WrappedMonad m Project)
    -> Maybe Project -> WrappedMonad m (Maybe Project))
-> (Project -> WrappedMonad m Project)
-> ModuleLocation
-> WrappedMonad m ModuleLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Project -> WrappedMonad m Project)
-> Maybe Project -> WrappedMonad m (Maybe Project)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just) Project -> m Project
forall (m :: * -> *). UpdateMonad m => Project -> m Project
refineProjectInfo Module
m
		Level -> Text -> m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Format
"Inferring types for {}" Format -> ModuleLocation -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ Getting ModuleLocation Module ModuleLocation
-> Module -> ModuleLocation
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((ModuleId -> Const ModuleLocation ModuleId)
-> Module -> Const ModuleLocation Module
Lens' Module ModuleId
moduleId ((ModuleId -> Const ModuleLocation ModuleId)
 -> Module -> Const ModuleLocation Module)
-> ((ModuleLocation -> Const ModuleLocation ModuleLocation)
    -> ModuleId -> Const ModuleLocation ModuleId)
-> Getting ModuleLocation Module ModuleLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleLocation -> Const ModuleLocation ModuleLocation)
-> ModuleId -> Const ModuleLocation ModuleId
Lens' ModuleId ModuleLocation
moduleLocation) Module
m'

		Session
sess <- m Session
forall (m :: * -> *). SessionMonad m => m Session
getSession
		Maybe Text
mcts <- (Maybe (POSIXTime, Text) -> Maybe Text)
-> m (Maybe (POSIXTime, Text)) -> m (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((POSIXTime, Text) -> Text)
-> Maybe (POSIXTime, Text) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (POSIXTime, Text) -> Text
forall a b. (a, b) -> b
snd) (m (Maybe (POSIXTime, Text)) -> m (Maybe Text))
-> m (Maybe (POSIXTime, Text)) -> m (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> m (Maybe (POSIXTime, Text))
forall (m :: * -> *).
SessionMonad m =>
Text -> m (Maybe (POSIXTime, Text))
S.getFileContents (Module
m' Module -> Getting (Endo Text) Module Text -> Text
forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! (ModuleId -> Const (Endo Text) ModuleId)
-> Module -> Const (Endo Text) Module
Lens' Module ModuleId
moduleId ((ModuleId -> Const (Endo Text) ModuleId)
 -> Module -> Const (Endo Text) Module)
-> ((Text -> Const (Endo Text) Text)
    -> ModuleId -> Const (Endo Text) ModuleId)
-> Getting (Endo Text) Module Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleLocation -> Const (Endo Text) ModuleLocation)
-> ModuleId -> Const (Endo Text) ModuleId
Lens' ModuleId ModuleLocation
moduleLocation ((ModuleLocation -> Const (Endo Text) ModuleLocation)
 -> ModuleId -> Const (Endo Text) ModuleId)
-> Getting (Endo Text) ModuleLocation Text
-> (Text -> Const (Endo Text) Text)
-> ModuleId
-> Const (Endo Text) ModuleId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Endo Text) ModuleLocation Text
Traversal' ModuleLocation Text
moduleFile)
		[Note TypedExpr]
types' <- GhcM [Note TypedExpr] -> m [Note TypedExpr]
forall (m :: * -> *) a. SessionMonad m => GhcM a -> m a
inSessionGhc (GhcM [Note TypedExpr] -> m [Note TypedExpr])
-> GhcM [Note TypedExpr] -> m [Note TypedExpr]
forall a b. (a -> b) -> a -> b
$ do
			[String] -> Module -> GhcM ()
targetSession [] Module
m'
			Session
-> [ModuleLocation]
-> GhcM [Note TypedExpr]
-> GhcM [Note TypedExpr]
forall a. Session -> [ModuleLocation] -> GhcM a -> GhcM a
cacheGhcWarnings Session
sess (Module
m' Module
-> Getting (Endo [ModuleLocation]) Module ModuleLocation
-> [ModuleLocation]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. (ModuleId -> Const (Endo [ModuleLocation]) ModuleId)
-> Module -> Const (Endo [ModuleLocation]) Module
Lens' Module ModuleId
moduleId ((ModuleId -> Const (Endo [ModuleLocation]) ModuleId)
 -> Module -> Const (Endo [ModuleLocation]) Module)
-> ((ModuleLocation
     -> Const (Endo [ModuleLocation]) ModuleLocation)
    -> ModuleId -> Const (Endo [ModuleLocation]) ModuleId)
-> Getting (Endo [ModuleLocation]) Module ModuleLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleLocation -> Const (Endo [ModuleLocation]) ModuleLocation)
-> ModuleId -> Const (Endo [ModuleLocation]) ModuleId
Lens' ModuleId ModuleLocation
moduleLocation) (GhcM [Note TypedExpr] -> GhcM [Note TypedExpr])
-> GhcM [Note TypedExpr] -> GhcM [Note TypedExpr]
forall a b. (a -> b) -> a -> b
$
				Module -> Maybe Text -> GhcM [Note TypedExpr]
forall (m :: * -> *).
(MonadLog m, MonadFail m, GhcMonad m) =>
Module -> Maybe Text -> m [Note TypedExpr]
fileTypes Module
m' Maybe Text
mcts

		ModuleId -> [Note TypedExpr] -> m ()
forall (m :: * -> *).
UpdateMonad m =>
ModuleId -> [Note TypedExpr] -> m ()
setModTypes (Module
m' Module -> Getting ModuleId Module ModuleId -> ModuleId
forall s a. s -> Getting a s a -> a
^. Getting ModuleId Module ModuleId
Lens' Module ModuleId
moduleId) [Note TypedExpr]
types'

-- | Generic scan function. Removed obsolete modules and calls callback on changed modules.
scan :: UpdateMonad m
	=> m [SQLite.Only Int SQLite.:. ModuleLocation SQLite.:. Inspection]
	-- ^ Get affected modules, obsolete will be removed, changed will be updated
	-> [S.ModuleToScan]
	-- ^ Actual modules, other will be removed
	-> [String]
	-- ^ Extra scan options
	-> ([S.ModuleToScan] -> m ())
	-- ^ Update function
	-> m ()
scan :: m [Only Int :. (ModuleLocation :. Inspection)]
-> [ModuleToScan] -> [String] -> ([ModuleToScan] -> m ()) -> m ()
scan m [Only Int :. (ModuleLocation :. Inspection)]
part' [ModuleToScan]
mlocs [String]
opts [ModuleToScan] -> m ()
act = Text -> m () -> m ()
forall (m :: * -> *) a.
(MonadLog m, HasCallStack) =>
Text -> m a -> m a
Log.scope Text
"scan" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
	Map ModuleLocation (Int, Inspection)
mlocs' <- ([Only Int :. (ModuleLocation :. Inspection)]
 -> Map ModuleLocation (Int, Inspection))
-> m [Only Int :. (ModuleLocation :. Inspection)]
-> m (Map ModuleLocation (Int, Inspection))
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ([(ModuleLocation, (Int, Inspection))]
-> Map ModuleLocation (Int, Inspection)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(ModuleLocation, (Int, Inspection))]
 -> Map ModuleLocation (Int, Inspection))
-> ([Only Int :. (ModuleLocation :. Inspection)]
    -> [(ModuleLocation, (Int, Inspection))])
-> [Only Int :. (ModuleLocation :. Inspection)]
-> Map ModuleLocation (Int, Inspection)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Only Int :. (ModuleLocation :. Inspection))
 -> (ModuleLocation, (Int, Inspection)))
-> [Only Int :. (ModuleLocation :. Inspection)]
-> [(ModuleLocation, (Int, Inspection))]
forall a b. (a -> b) -> [a] -> [b]
map (\(SQLite.Only Int
mid SQLite.:. (ModuleLocation
m SQLite.:. Inspection
i)) -> (ModuleLocation
m, (Int
mid, Inspection
i)))) m [Only Int :. (ModuleLocation :. Inspection)]
part'
	let
		obsolete :: Map ModuleLocation (Int, Inspection)
obsolete = (ModuleLocation -> (Int, Inspection) -> Bool)
-> Map ModuleLocation (Int, Inspection)
-> Map ModuleLocation (Int, Inspection)
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (\ModuleLocation
k (Int, Inspection)
_ -> ModuleLocation
k ModuleLocation -> Set ModuleLocation -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` [ModuleLocation] -> Set ModuleLocation
forall a. Ord a => [a] -> Set a
S.fromList ((ModuleToScan -> ModuleLocation)
-> [ModuleToScan] -> [ModuleLocation]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleToScan
-> Getting ModuleLocation ModuleToScan ModuleLocation
-> ModuleLocation
forall s a. s -> Getting a s a -> a
^. Getting ModuleLocation ModuleToScan ModuleLocation
forall s t a b. Field1 s t a b => Lens s t a b
_1) [ModuleToScan]
mlocs)) Map ModuleLocation (Int, Inspection)
mlocs'
	[ModuleToScan]
changed <- Map ModuleLocation Inspection
-> [String] -> [ModuleToScan] -> m [ModuleToScan]
forall (m :: * -> *).
SessionMonad m =>
Map ModuleLocation Inspection
-> [String] -> [ModuleToScan] -> m [ModuleToScan]
S.changedModules (((Int, Inspection) -> Inspection)
-> Map ModuleLocation (Int, Inspection)
-> Map ModuleLocation Inspection
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (Int, Inspection) -> Inspection
forall a b. (a, b) -> b
snd Map ModuleLocation (Int, Inspection)
mlocs') [String]
opts [ModuleToScan]
mlocs
	ServerM IO () -> m ()
forall (m :: * -> *). UpdateMonad m => ServerM IO () -> m ()
sendUpdateAction (ServerM IO () -> m ()) -> ServerM IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> ServerM IO () -> ServerM IO ()
forall (m :: * -> *) a.
(MonadLog m, HasCallStack) =>
Text -> m a -> m a
Log.scope Text
"remove-obsolete" (ServerM IO () -> ServerM IO ()) -> ServerM IO () -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ ServerM IO () -> ServerM IO ()
forall (m :: * -> *) a. SessionMonad m => m a -> m a
transact (ServerM IO () -> ServerM IO ()) -> ServerM IO () -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$
		[(Int, Inspection)]
-> ((Int, Inspection) -> ServerM IO ()) -> ServerM IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map ModuleLocation (Int, Inspection) -> [(Int, Inspection)]
forall k a. Map k a -> [a]
M.elems Map ModuleLocation (Int, Inspection)
obsolete) (((Int, Inspection) -> ServerM IO ()) -> ServerM IO ())
-> ((Int, Inspection) -> ServerM IO ()) -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ Int -> ServerM IO ()
forall (m :: * -> *). SessionMonad m => Int -> m ()
SQLite.removeModule (Int -> ServerM IO ())
-> ((Int, Inspection) -> Int) -> (Int, Inspection) -> ServerM IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Inspection) -> Int
forall a b. (a, b) -> a
fst
	[ModuleToScan] -> m ()
act [ModuleToScan]
changed

processEvents :: ([(Watched, Event)] -> IO ()) -> MVar (A.Async ()) -> MVar [(Watched, Event)] -> [(Watched, Event)] -> ClientM IO ()
processEvents :: ([(Watched, Event)] -> IO ())
-> MVar (Async ())
-> MVar [(Watched, Event)]
-> [(Watched, Event)]
-> ClientM IO ()
processEvents [(Watched, Event)] -> IO ()
handleEvents MVar (Async ())
updaterTask MVar [(Watched, Event)]
eventsVar [(Watched, Event)]
evs = Text -> ClientM IO () -> ClientM IO ()
forall (m :: * -> *) a.
(MonadLog m, HasCallStack) =>
Text -> m a -> m a
Log.scope Text
"event" (ClientM IO () -> ClientM IO ()) -> ClientM IO () -> ClientM IO ()
forall a b. (a -> b) -> a -> b
$ do
	Level -> Text -> ClientM IO ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace (Text -> ClientM IO ()) -> Text -> ClientM IO ()
forall a b. (a -> b) -> a -> b
$ Format
"events received: {}" Format -> String -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ([(Watched, Event)]
evs [(Watched, Event)]
-> Getting (Endo [String]) [(Watched, Event)] String -> [String]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. ((Watched, Event) -> Const (Endo [String]) (Watched, Event))
-> [(Watched, Event)] -> Const (Endo [String]) [(Watched, Event)]
forall s t a b. Each s t a b => Traversal s t a b
each (((Watched, Event) -> Const (Endo [String]) (Watched, Event))
 -> [(Watched, Event)] -> Const (Endo [String]) [(Watched, Event)])
-> ((String -> Const (Endo [String]) String)
    -> (Watched, Event) -> Const (Endo [String]) (Watched, Event))
-> Getting (Endo [String]) [(Watched, Event)] String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Event -> Const (Endo [String]) Event)
-> (Watched, Event) -> Const (Endo [String]) (Watched, Event)
forall s t a b. Field2 s t a b => Lens s t a b
_2 ((Event -> Const (Endo [String]) Event)
 -> (Watched, Event) -> Const (Endo [String]) (Watched, Event))
-> ((String -> Const (Endo [String]) String)
    -> Event -> Const (Endo [String]) Event)
-> (String -> Const (Endo [String]) String)
-> (Watched, Event)
-> Const (Endo [String]) (Watched, Event)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Const (Endo [String]) String)
-> Event -> Const (Endo [String]) Event
Lens' Event String
eventPath)
	Log
l <- ClientM IO Log
forall (m :: * -> *). MonadLog m => m Log
Log.askLog
	IO () -> ClientM IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ClientM IO ()) -> IO () -> ClientM IO ()
forall a b. (a -> b) -> a -> b
$ do
		MVar [(Watched, Event)]
-> ([(Watched, Event)] -> IO [(Watched, Event)]) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar [(Watched, Event)]
eventsVar ([(Watched, Event)] -> IO [(Watched, Event)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Watched, Event)] -> IO [(Watched, Event)])
-> ([(Watched, Event)] -> [(Watched, Event)])
-> [(Watched, Event)]
-> IO [(Watched, Event)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Watched, Event)] -> [(Watched, Event)] -> [(Watched, Event)]
forall a. [a] -> [a] -> [a]
++[(Watched, Event)]
evs))
		MVar (Async ()) -> (Async () -> IO (Async ())) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Async ())
updaterTask ((Async () -> IO (Async ())) -> IO ())
-> (Async () -> IO (Async ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Async ()
task -> do
			Bool
done <- (Maybe (Either SomeException ()) -> Bool)
-> IO (Maybe (Either SomeException ())) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Either SomeException ()) -> Bool
forall a. Maybe a -> Bool
isJust (IO (Maybe (Either SomeException ())) -> IO Bool)
-> IO (Maybe (Either SomeException ())) -> IO Bool
forall a b. (a -> b) -> a -> b
$ Async () -> IO (Maybe (Either SomeException ()))
forall a. Async a -> IO (Maybe (Either SomeException a))
poll Async ()
task
			if Bool
done
				then do
					Log -> LogT IO () -> IO ()
forall (m :: * -> *) a. Log -> LogT m a -> m a
Log.withLog Log
l (LogT IO () -> IO ()) -> LogT IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Level -> Text -> LogT IO ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace Text
"starting update thread"
					IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
A.async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ (IO () -> IO ()) -> IO ()
forall a. (a -> a) -> a
fix ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IO ()
loop -> do
						[(Watched, Event)]
updates <- MVar [(Watched, Event)]
-> ([(Watched, Event)]
    -> IO ([(Watched, Event)], [(Watched, Event)]))
-> IO [(Watched, Event)]
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar [(Watched, Event)]
eventsVar (\[(Watched, Event)]
es -> ([(Watched, Event)], [(Watched, Event)])
-> IO ([(Watched, Event)], [(Watched, Event)])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [(Watched, Event)]
es))
						Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(Watched, Event)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Watched, Event)]
updates) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [(Watched, Event)] -> IO ()
handleEvents [(Watched, Event)]
updates IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
loop
				else Async () -> IO (Async ())
forall (m :: * -> *) a. Monad m => a -> m a
return Async ()
task

updateEvents :: ServerMonadBase m => [(Watched, Event)] -> UpdateM m ()
updateEvents :: [(Watched, Event)] -> UpdateM m ()
updateEvents [(Watched, Event)]
updates = Text -> UpdateM m () -> UpdateM m ()
forall (m :: * -> *) a.
(MonadLog m, HasCallStack) =>
Text -> m a -> m a
Log.scope Text
"updater" (UpdateM m () -> UpdateM m ()) -> UpdateM m () -> UpdateM m ()
forall a b. (a -> b) -> a -> b
$ do
	Level -> Text -> UpdateM m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace (Text -> UpdateM m ()) -> Text -> UpdateM m ()
forall a b. (a -> b) -> a -> b
$ Format
"prepared to process {} events" Format -> Int -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ [(Watched, Event)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Watched, Event)]
updates
	[(FileSource, [String])]
files <- ([[(FileSource, [String])]] -> [(FileSource, [String])])
-> UpdateM m [[(FileSource, [String])]]
-> UpdateM m [(FileSource, [String])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[(FileSource, [String])]] -> [(FileSource, [String])]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (UpdateM m [[(FileSource, [String])]]
 -> UpdateM m [(FileSource, [String])])
-> UpdateM m [[(FileSource, [String])]]
-> UpdateM m [(FileSource, [String])]
forall a b. (a -> b) -> a -> b
$ [(Watched, Event)]
-> ((Watched, Event) -> UpdateM m [(FileSource, [String])])
-> UpdateM m [[(FileSource, [String])]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Watched, Event)]
updates (((Watched, Event) -> UpdateM m [(FileSource, [String])])
 -> UpdateM m [[(FileSource, [String])]])
-> ((Watched, Event) -> UpdateM m [(FileSource, [String])])
-> UpdateM m [[(FileSource, [String])]]
forall a b. (a -> b) -> a -> b
$ \(Watched
w, Event
e) -> case Watched
w of
		WatchedProject Project
proj [String]
projOpts
			| Event -> Bool
isSource Event
e -> do
				Level -> Text -> UpdateM m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Info (Text -> UpdateM m ()) -> Text -> UpdateM m ()
forall a b. (a -> b) -> a -> b
$ Format
"File '{file}' in project {proj} changed"
					Format -> FormatArg -> Format
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ (String
"file" String -> String -> FormatArg
forall a. Formattable a => String -> a -> FormatArg
~% Getting String Event String -> Event -> String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting String Event String
Lens' Event String
eventPath Event
e)
					Format -> FormatArg -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ (String
"proj" String -> Text -> FormatArg
forall a. Formattable a => String -> a -> FormatArg
~% Getting Text Project Text -> Project -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text Project Text
Lens' Project Text
projectName Project
proj)
				[SQLite.Only Maybe Value
mopts] <- Query -> Only String -> UpdateM m [Only (Maybe Value)]
forall q r (m :: * -> *).
(ToRow q, FromRow r, SessionMonad m) =>
Query -> q -> m [r]
SQLite.query Query
"select inspection_opts from modules where file == ?;" (String -> Only String
forall a. a -> Only a
SQLite.Only (String -> Only String) -> String -> Only String
forall a b. (a -> b) -> a -> b
$ Getting String Event String -> Event -> String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting String Event String
Lens' Event String
eventPath Event
e)
				[String]
opts <- UpdateM m [String]
-> (Value -> UpdateM m [String])
-> Maybe Value
-> UpdateM m [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([String] -> UpdateM m [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []) (UpdateM m [String]
-> ([String] -> UpdateM m [String])
-> Maybe [String]
-> UpdateM m [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe Value -> UpdateM m [String]
forall (m :: * -> *) a b. (MonadLog m, Show a) => a -> m b
parseErr' Maybe Value
mopts) [String] -> UpdateM m [String]
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [String] -> UpdateM m [String])
-> (Value -> Maybe [String]) -> Value -> UpdateM m [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Maybe [String]
forall a. FromJSON a => Value -> Maybe a
fromJSON') Maybe Value
mopts
				[(FileSource, [String])] -> UpdateM m [(FileSource, [String])]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Text -> Maybe Text -> FileSource
FileSource (String -> Text
fromFilePath (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Getting String Event String -> Event -> String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting String Event String
Lens' Event String
eventPath Event
e) Maybe Text
forall a. Maybe a
Nothing, [String]
opts)]
			| Event -> Bool
isCabal Event
e -> do
				Level -> Text -> UpdateM m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Info (Text -> UpdateM m ()) -> Text -> UpdateM m ()
forall a b. (a -> b) -> a -> b
$ Format
"Project {proj} changed"
					Format -> FormatArg -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ (String
"proj" String -> Text -> FormatArg
forall a. Formattable a => String -> a -> FormatArg
~% Getting Text Project Text -> Project -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text Project Text
Lens' Project Text
projectName Project
proj)
				[String] -> BuildTool -> Text -> UpdateM m ()
forall (m :: * -> *).
UpdateMonad m =>
[String] -> BuildTool -> Text -> m ()
scanProject [String]
projOpts (Getting BuildTool Project BuildTool -> Project -> BuildTool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting BuildTool Project BuildTool
Lens' Project BuildTool
projectBuildTool Project
proj) (Getting Text Project Text -> Project -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text Project Text
Lens' Project Text
projectCabal Project
proj)
				[(FileSource, [String])] -> UpdateM m [(FileSource, [String])]
forall (m :: * -> *) a. Monad m => a -> m a
return []
			| Bool
otherwise -> [(FileSource, [String])] -> UpdateM m [(FileSource, [String])]
forall (m :: * -> *) a. Monad m => a -> m a
return []
		WatchedPackageDb PackageDbStack
pdbs [String]
opts
			| Event -> Bool
isConf Event
e -> do
				Level -> Text -> UpdateM m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Info (Text -> UpdateM m ()) -> Text -> UpdateM m ()
forall a b. (a -> b) -> a -> b
$ Format
"Package db {package} changed"
					Format -> FormatArg -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ (String
"package" String -> PackageDb -> FormatArg
forall a. Formattable a => String -> a -> FormatArg
~% PackageDbStack -> PackageDb
topPackageDb PackageDbStack
pdbs)
				[String] -> PackageDbStack -> UpdateM m ()
forall (m :: * -> *).
UpdateMonad m =>
[String] -> PackageDbStack -> m ()
scanPackageDb [String]
opts PackageDbStack
pdbs
				[(FileSource, [String])] -> UpdateM m [(FileSource, [String])]
forall (m :: * -> *) a. Monad m => a -> m a
return []
			| Bool
otherwise -> [(FileSource, [String])] -> UpdateM m [(FileSource, [String])]
forall (m :: * -> *) a. Monad m => a -> m a
return []
		Watched
WatchedModule
			| Event -> Bool
isSource Event
e -> do
				Level -> Text -> UpdateM m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Info (Text -> UpdateM m ()) -> Text -> UpdateM m ()
forall a b. (a -> b) -> a -> b
$ Format
"Module {file} changed"
					Format -> FormatArg -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ (String
"file" String -> String -> FormatArg
forall a. Formattable a => String -> a -> FormatArg
~% Getting String Event String -> Event -> String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting String Event String
Lens' Event String
eventPath Event
e)
				[SQLite.Only Maybe Value
mopts] <- Query -> Only String -> UpdateM m [Only (Maybe Value)]
forall q r (m :: * -> *).
(ToRow q, FromRow r, SessionMonad m) =>
Query -> q -> m [r]
SQLite.query Query
"select inspection_opts from modules where file == ?;" (String -> Only String
forall a. a -> Only a
SQLite.Only (String -> Only String) -> String -> Only String
forall a b. (a -> b) -> a -> b
$ Getting String Event String -> Event -> String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting String Event String
Lens' Event String
eventPath Event
e)
				[String]
opts <- UpdateM m [String]
-> (Value -> UpdateM m [String])
-> Maybe Value
-> UpdateM m [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([String] -> UpdateM m [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []) (UpdateM m [String]
-> ([String] -> UpdateM m [String])
-> Maybe [String]
-> UpdateM m [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe Value -> UpdateM m [String]
forall (m :: * -> *) a b. (MonadLog m, Show a) => a -> m b
parseErr' Maybe Value
mopts) [String] -> UpdateM m [String]
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [String] -> UpdateM m [String])
-> (Value -> Maybe [String]) -> Value -> UpdateM m [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Maybe [String]
forall a. FromJSON a => Value -> Maybe a
fromJSON') Maybe Value
mopts
				[(FileSource, [String])] -> UpdateM m [(FileSource, [String])]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Text -> Maybe Text -> FileSource
FileSource (String -> Text
fromFilePath (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Getting String Event String -> Event -> String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting String Event String
Lens' Event String
eventPath Event
e) Maybe Text
forall a. Maybe a
Nothing, [String]
opts)]
			| Bool
otherwise -> [(FileSource, [String])] -> UpdateM m [(FileSource, [String])]
forall (m :: * -> *) a. Monad m => a -> m a
return []
	[(FileSource, [String])] -> UpdateM m ()
forall (m :: * -> *).
UpdateMonad m =>
[(FileSource, [String])] -> m ()
scanFiles [(FileSource, [String])]
files
	where
		parseErr' :: a -> m b
parseErr' a
mopts' = do
			Level -> Text -> m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Error (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Format
"Error parsing inspection_opts: {}" Format -> String -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ a -> String
forall a. Show a => a -> String
show a
mopts'
			HsDevError -> m b
forall (m :: * -> *) a. MonadThrow m => HsDevError -> m a
hsdevError (HsDevError -> m b) -> HsDevError -> m b
forall a b. (a -> b) -> a -> b
$ String -> HsDevError
SQLiteError (String -> HsDevError) -> String -> HsDevError
forall a b. (a -> b) -> a -> b
$ Format
"Error parsing inspection_opts: {}" Format -> String -> String
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ a -> String
forall a. Show a => a -> String
show a
mopts'

applyUpdates :: UpdateOptions -> [(Watched, Event)] -> ClientM IO ()
applyUpdates :: UpdateOptions -> [(Watched, Event)] -> ClientM IO ()
applyUpdates UpdateOptions
uopts = UpdateOptions -> UpdateM IO () -> ClientM IO ()
forall (m :: * -> *) a.
ServerMonadBase m =>
UpdateOptions -> UpdateM m a -> ClientM m a
runUpdate UpdateOptions
uopts (UpdateM IO () -> ClientM IO ())
-> ([(Watched, Event)] -> UpdateM IO ())
-> [(Watched, Event)]
-> ClientM IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Watched, Event)] -> UpdateM IO ()
forall (m :: * -> *).
ServerMonadBase m =>
[(Watched, Event)] -> UpdateM m ()
updateEvents

-- Save ghc warnings on loading target, because second loading won't produce any
cacheGhcWarnings :: Session -> [ModuleLocation] -> GhcM a -> GhcM a
cacheGhcWarnings :: Session -> [ModuleLocation] -> GhcM a -> GhcM a
cacheGhcWarnings Session
sess [ModuleLocation]
mlocs GhcM a
act = Text -> GhcM a -> GhcM a
forall (m :: * -> *) a.
(MonadLog m, HasCallStack) =>
Text -> m a -> m a
Log.scope Text
"cache-warnings" (GhcM a -> GhcM a) -> GhcM a -> GhcM a
forall a b. (a -> b) -> a -> b
$ do
	POSIXTime
tm <- IO POSIXTime
-> MGhcT SessionConfig (First DynFlags) (LogT IO) POSIXTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO POSIXTime
getPOSIXTime
	(a
r, [Note OutputMessage]
msgs) <- GhcM a
-> MGhcT
     SessionConfig (First DynFlags) (LogT IO) (a, [Note OutputMessage])
forall (m :: * -> *) a.
GhcMonad m =>
m a -> m (a, [Note OutputMessage])
collectMessages GhcM a
act
	Level -> Text -> GhcM ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace (Text -> GhcM ()) -> Text -> GhcM ()
forall a b. (a -> b) -> a -> b
$ Format
"collected {} warnings" Format -> Int -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ [Note OutputMessage] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Note OutputMessage]
msgs
	Async ()
_ <- IO (Async ())
-> MGhcT SessionConfig (First DynFlags) (LogT IO) (Async ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Async ())
 -> MGhcT SessionConfig (First DynFlags) (LogT IO) (Async ()))
-> IO (Async ())
-> MGhcT SessionConfig (First DynFlags) (LogT IO) (Async ())
forall a b. (a -> b) -> a -> b
$ Session -> ServerM IO (Async ()) -> IO (Async ())
forall (m :: * -> *) a. Session -> ServerM m a -> m a
withSession Session
sess (ServerM IO (Async ()) -> IO (Async ()))
-> ServerM IO (Async ()) -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ ServerM IO () -> ServerM IO (Async ())
forall (m :: * -> *) a.
SessionMonad m =>
ServerM IO a -> m (Async a)
postSessionUpdater (ServerM IO () -> ServerM IO (Async ()))
-> ServerM IO () -> ServerM IO (Async ())
forall a b. (a -> b) -> a -> b
$ [ModuleLocation]
-> POSIXTime -> [Note OutputMessage] -> ServerM IO ()
refreshCache [ModuleLocation]
mlocs POSIXTime
tm [Note OutputMessage]
msgs
	a -> GhcM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r
	where
		refreshCache :: [ModuleLocation] -> POSIXTime -> [Note OutputMessage] -> ServerM IO ()
		refreshCache :: [ModuleLocation]
-> POSIXTime -> [Note OutputMessage] -> ServerM IO ()
refreshCache [ModuleLocation]
mlocs' POSIXTime
tm' [Note OutputMessage]
msgs' = Text -> ServerM IO () -> ServerM IO ()
forall (m :: * -> *) a.
(MonadLog m, HasCallStack) =>
Text -> m a -> m a
Log.scope Text
"refresh" (ServerM IO () -> ServerM IO ()) -> ServerM IO () -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ ServerM IO () -> ServerM IO () -> ServerM IO () -> ServerM IO ()
forall (m :: * -> *) a c b. MonadMask m => m a -> m c -> m b -> m b
bracket_ ServerM IO ()
forall (m :: * -> *). SessionMonad m => m ()
initTemp ServerM IO ()
forall (m :: * -> *). SessionMonad m => m ()
dropTemp (ServerM IO () -> ServerM IO ()) -> ServerM IO () -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ do
			ServerM IO ()
forall (m :: * -> *). SessionMonad m => m ()
fillTemp
			ServerM IO ()
forall (m :: * -> *). SessionMonad m => m ()
removeOutdated
			ServerM IO ()
forall (m :: * -> *). SessionMonad m => m ()
insertMessages
			where
				initTemp :: SessionMonad m => m ()
				initTemp :: m ()
initTemp = do
					Query -> m ()
forall (m :: * -> *). SessionMonad m => Query -> m ()
SQLite.execute_ Query
"create temporary table updating_files (file text not null, mtime real not null);"
					Query -> m ()
forall (m :: * -> *). SessionMonad m => Query -> m ()
SQLite.execute_ Query
"create index updating_files_index on updating_files (file);"
					Query -> m ()
forall (m :: * -> *). SessionMonad m => Query -> m ()
SQLite.execute_ Query
"create temporary table updating_ids (id integer not null unique, mtime real);"
					Query -> m ()
forall (m :: * -> *). SessionMonad m => Query -> m ()
SQLite.execute_ Query
"create temporary table updating_messages as select * from messages where 0;"
					Query -> m ()
forall (m :: * -> *). SessionMonad m => Query -> m ()
SQLite.execute_ Query
"create index update_messages_module_id_index on updating_messages (module_id);"

				dropTemp :: SessionMonad m => m ()
				dropTemp :: m ()
dropTemp = do
					Query -> m ()
forall (m :: * -> *). SessionMonad m => Query -> m ()
SQLite.execute_ Query
"drop table if exists updating_files;"
					Query -> m ()
forall (m :: * -> *). SessionMonad m => Query -> m ()
SQLite.execute_ Query
"drop table if exists updating_ids;"
					Query -> m ()
forall (m :: * -> *). SessionMonad m => Query -> m ()
SQLite.execute_ Query
"drop table if exists updating_messages;"

				fillTemp :: SessionMonad m => m ()
				fillTemp :: m ()
fillTemp = do
					[(Text, POSIXTime)]
mtimes <- [Text] -> (Text -> m (Text, POSIXTime)) -> m [(Text, POSIXTime)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([ModuleLocation]
mlocs' [ModuleLocation]
-> Getting (Endo [Text]) [ModuleLocation] Text -> [Text]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. (ModuleLocation -> Const (Endo [Text]) ModuleLocation)
-> [ModuleLocation] -> Const (Endo [Text]) [ModuleLocation]
forall s t a b. Each s t a b => Traversal s t a b
each ((ModuleLocation -> Const (Endo [Text]) ModuleLocation)
 -> [ModuleLocation] -> Const (Endo [Text]) [ModuleLocation])
-> ((Text -> Const (Endo [Text]) Text)
    -> ModuleLocation -> Const (Endo [Text]) ModuleLocation)
-> Getting (Endo [Text]) [ModuleLocation] Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const (Endo [Text]) Text)
-> ModuleLocation -> Const (Endo [Text]) ModuleLocation
Traversal' ModuleLocation Text
moduleFile) ((Text -> m (Text, POSIXTime)) -> m [(Text, POSIXTime)])
-> (Text -> m (Text, POSIXTime)) -> m [(Text, POSIXTime)]
forall a b. (a -> b) -> a -> b
$ \Text
file' -> (,) (Text -> POSIXTime -> (Text, POSIXTime))
-> m Text -> m (POSIXTime -> (Text, POSIXTime))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
file' m (POSIXTime -> (Text, POSIXTime))
-> m POSIXTime -> m (Text, POSIXTime)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO POSIXTime -> m POSIXTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Text -> IO POSIXTime
fileMTime Text
file')
					Query -> [(Text, POSIXTime)] -> m ()
forall q (m :: * -> *).
(ToRow q, SessionMonad m) =>
Query -> [q] -> m ()
SQLite.executeMany Query
"insert into updating_files values (?, ?);" [(Text, POSIXTime)]
mtimes
					Query -> m ()
forall (m :: * -> *). SessionMonad m => Query -> m ()
SQLite.execute_ Query
"update updating_files set mtime = coalesce(max(mtime, (select c.mtime from file_contents as c where c.file == updating_files.file)), mtime);"
					Query -> m ()
forall (m :: * -> *). SessionMonad m => Query -> m ()
SQLite.execute_ Query
"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;"
					Query -> [Note OutputMessage] -> m ()
forall q (m :: * -> *).
(ToRow q, SessionMonad m) =>
Query -> [q] -> m ()
SQLite.executeMany Query
"insert into updating_messages select (select m.id from modules as m where (m.file = ?)), ?, ?, ?, ?, ?, ?, ?;" [Note OutputMessage]
msgs'
					Query -> m ()
forall (m :: * -> *). SessionMonad m => Query -> m ()
SQLite.execute_ Query
"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 :: m ()
removeOutdated = Query -> m ()
forall (m :: * -> *). SessionMonad m => Query -> m ()
SQLite.execute_ (Query -> m ()) -> Query -> m ()
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] -> String
unlines [
					String
"delete from messages",
					String
"where",
					String
" module_id in (",
					String
"  select um.id",
					String
"  from updating_ids as um",
					String
"  left outer join load_times as lt",
					String
"  on lt.module_id = um.id",
					String
"  where",
					String
"   lt.load_time is null or",
					String
"   lt.load_time <= um.mtime or",
					String
"   um.id in (select distinct umsgs.module_id from updating_messages as umsgs)",
					String
" );"]

				insertMessages :: SessionMonad m => m ()
				insertMessages :: m ()
insertMessages = TransactionType -> m () -> m ()
forall (m :: * -> *) a.
SessionMonad m =>
TransactionType -> m a -> m a
SQLite.transaction_ TransactionType
SQLite.Deferred (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
					Query -> Only POSIXTime -> m ()
forall q (m :: * -> *).
(ToRow q, SessionMonad m) =>
Query -> q -> m ()
SQLite.execute Query
"insert or replace into load_times (module_id, load_time) select um.id, ? from updating_ids as um;" (POSIXTime -> Only POSIXTime
forall a. a -> Only a
SQLite.Only POSIXTime
tm')
					Query -> m ()
forall (m :: * -> *). SessionMonad m => Query -> m ()
SQLite.execute_ Query
"insert into messages select distinct * from updating_messages;"

-- | Get cached warnings
cachedWarnings :: SessionMonad m => [ModuleLocation] -> m [Note OutputMessage]
cachedWarnings :: [ModuleLocation] -> m [Note OutputMessage]
cachedWarnings [ModuleLocation]
mlocs = ([[Note OutputMessage]] -> [Note OutputMessage])
-> m [[Note OutputMessage]] -> m [Note OutputMessage]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[Note OutputMessage]] -> [Note OutputMessage]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (m [[Note OutputMessage]] -> m [Note OutputMessage])
-> m [[Note OutputMessage]] -> m [Note OutputMessage]
forall a b. (a -> b) -> a -> b
$ [Text]
-> (Text -> m [Note OutputMessage]) -> m [[Note OutputMessage]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([ModuleLocation]
mlocs [ModuleLocation]
-> Getting (Endo [Text]) [ModuleLocation] Text -> [Text]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. (ModuleLocation -> Const (Endo [Text]) ModuleLocation)
-> [ModuleLocation] -> Const (Endo [Text]) [ModuleLocation]
forall s t a b. Each s t a b => Traversal s t a b
each ((ModuleLocation -> Const (Endo [Text]) ModuleLocation)
 -> [ModuleLocation] -> Const (Endo [Text]) [ModuleLocation])
-> ((Text -> Const (Endo [Text]) Text)
    -> ModuleLocation -> Const (Endo [Text]) ModuleLocation)
-> Getting (Endo [Text]) [ModuleLocation] Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const (Endo [Text]) Text)
-> ModuleLocation -> Const (Endo [Text]) ModuleLocation
Traversal' ModuleLocation Text
moduleFile) ((Text -> m [Note OutputMessage]) -> m [[Note OutputMessage]])
-> (Text -> m [Note OutputMessage]) -> m [[Note OutputMessage]]
forall a b. (a -> b) -> a -> b
$ \Text
f -> Query -> Only Text -> m [Note OutputMessage]
forall q r (m :: * -> *).
(ToRow q, FromRow r, SessionMonad m) =>
Query -> q -> m [r]
SQLite.query @_ @(Note OutputMessage) (Select Text -> Query
SQLite.toQuery (Select Text -> Query) -> Select Text -> Query
forall a b. (a -> b) -> a -> b
$ [Select Text] -> Select Text
forall a. Monoid a => [a] -> a
mconcat [
	Text -> Text -> Select Text
SQLite.qNote Text
"m" Text
"n",
	[Text] -> Select Text
forall a. [a] -> Select a
SQLite.from_ [Text
"load_times as lt"],
	[Text] -> Select Text
forall a. [a] -> Select a
SQLite.where_ [
		Text
"lt.module_id = m.id",
		Text
"m.file = ?",
		Text
"lt.load_time >= m.inspection_time"]])
	(Text -> Only Text
forall a. a -> Only a
SQLite.Only Text
f)

watch :: SessionMonad m => (Watcher -> IO ()) -> m ()
watch :: (Watcher -> IO ()) -> m ()
watch Watcher -> IO ()
f = m (Maybe Watcher) -> (Watcher -> m ()) -> m ()
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m b) -> m ()
whenJustM ((Session -> Maybe Watcher) -> m (Maybe Watcher)
forall (m :: * -> *) a. SessionMonad m => (Session -> a) -> m a
askSession Session -> Maybe Watcher
sessionWatcher) ((Watcher -> m ()) -> m ()) -> (Watcher -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (Watcher -> IO ()) -> Watcher -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Watcher -> IO ()
f