{-# LANGUAGE OverloadedStrings, FlexibleContexts, TypeOperators, TypeApplications #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module HsDev.Client.Commands (
	runClient, runCommand
	) where

import Control.Arrow (second)
import Control.Concurrent.MVar
import Control.Exception (displayException)
import Control.Lens hiding ((.=), (<.>))
import Control.Monad
import Control.Monad.Morph
import Control.Monad.Except
import Control.Monad.Reader
import qualified Control.Monad.State as State
import Control.Monad.Catch (try, catch, bracket, SomeException(..))
import Data.Aeson hiding (Result, Error)
import Data.List
import Data.Maybe
import qualified Data.Map.Strict as M
import Data.Text (Text, pack, unpack)
import qualified Data.Text as T (append, null)
import System.Directory
import System.FilePath
import qualified System.Log.Simple as Log
import qualified System.Log.Simple.Base as Log
import Text.Read (readMaybe)

import Data.Maybe.JustIf
import qualified System.Directory.Watcher as W
import System.Directory.Paths
import Text.Format
import HsDev.Error
import HsDev.Database.SQLite as SQLite
import HsDev.Inspect (preload, asModule)
import HsDev.Scan (upToDate, getFileContents)
import HsDev.Server.Message as M
import HsDev.Server.Types
import HsDev.Sandbox hiding (findSandbox)
import qualified HsDev.Sandbox as S (findSandbox)
import HsDev.Symbols
import qualified HsDev.Tools.AutoFix as AutoFix
import qualified HsDev.Tools.Cabal as Cabal
import HsDev.Tools.Ghc.Session
import HsDev.Tools.Ghc.Worker (clearTargets)
import qualified HsDev.Tools.Ghc.Compat as Compat
import qualified HsDev.Tools.Ghc.Check as Check
import qualified HsDev.Tools.Ghc.Types as Types
import qualified HsDev.Tools.Hayoo as Hayoo
import qualified HsDev.Tools.HDocs as HDocs
import qualified HsDev.Tools.HLint as HLint
import qualified HsDev.Tools.Types as Tools
import HsDev.Util
import HsDev.Watcher

import qualified HsDev.Database.Update as Update

runClient :: (ToJSON a, ServerMonadBase m) => CommandOptions -> ClientM m a -> ServerM m Result
runClient :: CommandOptions -> ClientM m a -> ServerM m Result
runClient CommandOptions
copts = (ReaderT CommandOptions m a -> m Result)
-> ServerM (ReaderT CommandOptions m) a -> ServerM m Result
forall (m :: * -> *) a (n :: * -> *) b.
(m a -> n b) -> ServerM m a -> ServerM n b
mapServerM ReaderT CommandOptions m a -> m Result
forall a (m :: * -> *).
(ToJSON a, ServerMonadBase m) =>
ReaderT CommandOptions m a -> m Result
toResult (ServerM (ReaderT CommandOptions m) a -> ServerM m Result)
-> (ClientM m a -> ServerM (ReaderT CommandOptions m) a)
-> ClientM m a
-> ServerM m Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientM m a -> ServerM (ReaderT CommandOptions m) a
forall (m :: * -> *) a.
ClientM m a -> ServerM (ReaderT CommandOptions m) a
runClientM where
	toResult :: (ToJSON a, ServerMonadBase m) => ReaderT CommandOptions m a -> m Result
	toResult :: ReaderT CommandOptions m a -> m Result
toResult ReaderT CommandOptions m a
act = (Either SomeException (Either HsDevError a) -> Result)
-> m (Either SomeException (Either HsDevError a)) -> m Result
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Either SomeException (Either HsDevError a) -> Result
forall a.
ToJSON a =>
Either SomeException (Either HsDevError a) -> Result
errorToResult (m (Either SomeException (Either HsDevError a)) -> m Result)
-> m (Either SomeException (Either HsDevError a)) -> m Result
forall a b. (a -> b) -> a -> b
$ ReaderT
  CommandOptions m (Either SomeException (Either HsDevError a))
-> CommandOptions -> m (Either SomeException (Either HsDevError a))
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ReaderT CommandOptions m (Either HsDevError a)
-> ReaderT
     CommandOptions m (Either SomeException (Either HsDevError a))
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (ReaderT CommandOptions m a
-> ReaderT CommandOptions m (Either HsDevError a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try ReaderT CommandOptions m a
act)) CommandOptions
copts
	mapServerM :: (m a -> n b) -> ServerM m a -> ServerM n b
	mapServerM :: (m a -> n b) -> ServerM m a -> ServerM n b
mapServerM m a -> n b
f = ReaderT Session n b -> ServerM n b
forall (m :: * -> *) a. ReaderT Session m a -> ServerM m a
ServerM (ReaderT Session n b -> ServerM n b)
-> (ServerM m a -> ReaderT Session n b)
-> ServerM m a
-> ServerM n b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (m a -> n b) -> ReaderT Session m a -> ReaderT Session n b
forall (m :: * -> *) a (n :: * -> *) b r.
(m a -> n b) -> ReaderT r m a -> ReaderT r n b
mapReaderT m a -> n b
f (ReaderT Session m a -> ReaderT Session n b)
-> (ServerM m a -> ReaderT Session m a)
-> ServerM m a
-> ReaderT Session n b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerM m a -> ReaderT Session m a
forall (m :: * -> *) a. ServerM m a -> ReaderT Session m a
runServerM
	errorToResult :: ToJSON a => Either SomeException (Either HsDevError a) -> Result
	errorToResult :: Either SomeException (Either HsDevError a) -> Result
errorToResult = (SomeException -> Result)
-> (Either HsDevError a -> Result)
-> Either SomeException (Either HsDevError a)
-> Result
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (HsDevError -> Result
Error (HsDevError -> Result)
-> (SomeException -> HsDevError) -> SomeException -> Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HsDevError
UnhandledError (String -> HsDevError)
-> (SomeException -> String) -> SomeException -> HsDevError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall e. Exception e => e -> String
displayException) ((HsDevError -> Result)
-> (a -> Result) -> Either HsDevError a -> Result
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either HsDevError -> Result
Error (Value -> Result
Result (Value -> Result) -> (a -> Value) -> a -> Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Value
forall a. ToJSON a => a -> Value
toJSON))

toValue :: (ToJSON a, Monad m) => m a -> m Value
toValue :: m a -> m Value
toValue = (a -> Value) -> m a -> m Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Value
forall a. ToJSON a => a -> Value
toJSON

runCommand :: ServerMonadBase m => Command -> ClientM m Value
runCommand :: Command -> ClientM m Value
runCommand Command
Ping = ClientM m Value -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m Value -> ClientM m Value)
-> ClientM m Value -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ Value -> ClientM m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> ClientM m Value) -> Value -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [Text
"message" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (String
"pong" :: String)]
runCommand (Listen (Just String
l)) = case Text -> Maybe Level
Log.level (String -> Text
pack String
l) of
	Maybe Level
Nothing -> HsDevError -> ClientM m Value
forall (m :: * -> *) a. MonadThrow m => HsDevError -> m a
hsdevError (HsDevError -> ClientM m Value) -> HsDevError -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ String -> HsDevError
OtherError (String -> HsDevError) -> String -> HsDevError
forall a b. (a -> b) -> a -> b
$ Format
"invalid log level: {}" Format -> String -> String
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ String
l
	Just Level
lev -> ClientM m Level
-> (Level -> ClientM m Level)
-> (Level -> ClientM m Value)
-> ClientM m Value
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket (Level -> ClientM m Level
forall (m :: * -> *). SessionMonad m => Level -> m Level
serverSetLogLevel Level
lev) Level -> ClientM m Level
forall (m :: * -> *). SessionMonad m => Level -> m Level
serverSetLogLevel ((Level -> ClientM m Value) -> ClientM m Value)
-> (Level -> ClientM m Value) -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ \Level
_ -> Command -> ClientM m Value
forall (m :: * -> *).
ServerMonadBase m =>
Command -> ClientM m Value
runCommand (Maybe String -> Command
Listen Maybe String
forall a. Maybe a
Nothing)
runCommand (Listen Maybe String
Nothing) = ClientM m () -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m () -> ClientM m Value)
-> ClientM m () -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ do
	ClientM m [Message]
forall (m :: * -> *). SessionMonad m => m [Message]
serverListen ClientM m [Message] -> ([Message] -> ClientM m ()) -> ClientM m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Message -> ClientM m ()) -> [Message] -> ClientM m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Notification -> ClientM m ()
forall (m :: * -> *). CommandMonad m => Notification -> m ()
commandNotify (Notification -> ClientM m ())
-> (Message -> Notification) -> Message -> ClientM m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Notification
Notification (Value -> Notification)
-> (Message -> Value) -> Message -> Notification
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> Value
forall a. ToJSON a => a -> Value
toJSON)
runCommand (SetLogLevel String
l) = case Text -> Maybe Level
Log.level (String -> Text
pack String
l) of
	Maybe Level
Nothing -> HsDevError -> ClientM m Value
forall (m :: * -> *) a. MonadThrow m => HsDevError -> m a
hsdevError (HsDevError -> ClientM m Value) -> HsDevError -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ String -> HsDevError
OtherError (String -> HsDevError) -> String -> HsDevError
forall a b. (a -> b) -> a -> b
$ Format
"invalid log level: {}" Format -> String -> String
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ String
l
	Just Level
lev -> ClientM m () -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m () -> ClientM m Value)
-> ClientM m () -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ do
		Level
lev' <- Level -> ClientM m Level
forall (m :: * -> *). SessionMonad m => Level -> m Level
serverSetLogLevel Level
lev
		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
"log level changed from '{}' to '{}'" Format -> String -> Format
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ Level -> String
forall a. Show a => a -> String
show Level
lev' Format -> String -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ Level -> String
forall a. Show a => a -> String
show Level
lev
		Level -> Text -> ClientM m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Info (Text -> ClientM m ()) -> Text -> ClientM m ()
forall a b. (a -> b) -> a -> b
$ Format
"log level updated to: {}" Format -> String -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ Level -> String
forall a. Show a => a -> String
show Level
lev
runCommand (Scan [Text]
projs Bool
cabal [Text]
sboxes [FileSource]
fs [Text]
paths' BuildTool
btool [String]
ghcs' Bool
docs' Bool
infer') = ClientM m () -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m () -> ClientM m Value)
-> ClientM m () -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ do
	[Sandbox]
sboxes' <- [Text] -> ClientM m [Sandbox]
forall (m :: * -> *). CommandMonad m => [Text] -> m [Sandbox]
getSandboxes [Text]
sboxes
	UpdateOptions -> [UpdateM IO ()] -> ClientM m ()
forall (m :: * -> *).
ServerMonadBase m =>
UpdateOptions -> [UpdateM IO ()] -> ClientM m ()
updateProcess ([Task] -> [String] -> Bool -> Bool -> UpdateOptions
Update.UpdateOptions [] [String]
ghcs' Bool
docs' Bool
infer') ([UpdateM IO ()] -> ClientM m ())
-> [UpdateM IO ()] -> ClientM m ()
forall a b. (a -> b) -> a -> b
$ [[UpdateM IO ()]] -> [UpdateM IO ()]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
		[[String] -> UpdateM IO ()
forall (m :: * -> *). UpdateMonad m => [String] -> m ()
Update.scanCabal [String]
ghcs' | Bool
cabal],
		(Sandbox -> UpdateM IO ()) -> [Sandbox] -> [UpdateM IO ()]
forall a b. (a -> b) -> [a] -> [b]
map ([String] -> Sandbox -> UpdateM IO ()
forall (m :: * -> *). UpdateMonad m => [String] -> Sandbox -> m ()
Update.scanSandbox [String]
ghcs') [Sandbox]
sboxes',
		[[(FileSource, [String])] -> UpdateM IO ()
forall (m :: * -> *).
UpdateMonad m =>
[(FileSource, [String])] -> m ()
Update.scanFiles ([FileSource] -> [[String]] -> [(FileSource, [String])]
forall a b. [a] -> [b] -> [(a, b)]
zip [FileSource]
fs ([String] -> [[String]]
forall a. a -> [a]
repeat [String]
ghcs'))],
		(Text -> UpdateM IO ()) -> [Text] -> [UpdateM IO ()]
forall a b. (a -> b) -> [a] -> [b]
map ([String] -> BuildTool -> Text -> UpdateM IO ()
forall (m :: * -> *).
UpdateMonad m =>
[String] -> BuildTool -> Text -> m ()
Update.scanProject [String]
ghcs' BuildTool
btool) [Text]
projs,
		(Text -> UpdateM IO ()) -> [Text] -> [UpdateM IO ()]
forall a b. (a -> b) -> [a] -> [b]
map ([String] -> Text -> UpdateM IO ()
forall (m :: * -> *). UpdateMonad m => [String] -> Text -> m ()
Update.scanDirectory [String]
ghcs') [Text]
paths']
runCommand (ScanProject Text
proj BuildTool
tool Bool
deps) = ClientM m () -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m () -> ClientM m Value)
-> ClientM m () -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ UpdateOptions -> [UpdateM IO ()] -> ClientM m ()
forall (m :: * -> *).
ServerMonadBase m =>
UpdateOptions -> [UpdateM IO ()] -> ClientM m ()
updateProcess UpdateOptions
forall a. Default a => a
def [
	(if Bool
deps then [String] -> BuildTool -> Text -> UpdateM IO ()
forall (m :: * -> *).
UpdateMonad m =>
[String] -> BuildTool -> Text -> m ()
Update.scanProjectStack else [String] -> BuildTool -> Text -> UpdateM IO ()
forall (m :: * -> *).
UpdateMonad m =>
[String] -> BuildTool -> Text -> m ()
Update.scanProject) [] BuildTool
tool Text
proj]
runCommand (ScanFile Text
fpath BuildTool
tool Bool
scanProj Bool
deps) = ClientM m () -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m () -> ClientM m Value)
-> ClientM m () -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ UpdateOptions -> [UpdateM IO ()] -> ClientM m ()
forall (m :: * -> *).
ServerMonadBase m =>
UpdateOptions -> [UpdateM IO ()] -> ClientM m ()
updateProcess UpdateOptions
forall a. Default a => a
def [
	[String] -> Text -> BuildTool -> Bool -> Bool -> UpdateM IO ()
forall (m :: * -> *).
UpdateMonad m =>
[String] -> Text -> BuildTool -> Bool -> Bool -> m ()
Update.scanFile [] Text
fpath BuildTool
tool Bool
scanProj Bool
deps]
runCommand (ScanPackageDbs PackageDbStack
pdbs) = ClientM m () -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m () -> ClientM m Value)
-> ClientM m () -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ UpdateOptions -> [UpdateM IO ()] -> ClientM m ()
forall (m :: * -> *).
ServerMonadBase m =>
UpdateOptions -> [UpdateM IO ()] -> ClientM m ()
updateProcess UpdateOptions
forall a. Default a => a
def [
	[String] -> PackageDbStack -> UpdateM IO ()
forall (m :: * -> *).
UpdateMonad m =>
[String] -> PackageDbStack -> m ()
Update.scanPackageDbStack [] PackageDbStack
pdbs]
runCommand (SetFileContents Text
f Maybe Text
mcts) = ClientM m () -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m () -> ClientM m Value)
-> ClientM m () -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> ClientM m ()
forall (m :: * -> *). SessionMonad m => Text -> Maybe Text -> m ()
serverSetFileContents Text
f Maybe Text
mcts
runCommand (RefineDocs [Text]
projs [Text]
fs)
	| Bool
HDocs.hdocsSupported = ClientM m () -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m () -> ClientM m Value)
-> ClientM m () -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ UpdateOptions -> [UpdateM IO ()] -> ClientM m ()
forall (m :: * -> *).
ServerMonadBase m =>
UpdateOptions -> [UpdateM IO ()] -> ClientM m ()
updateProcess UpdateOptions
forall a. Default a => a
def ([UpdateM IO ()] -> ClientM m ())
-> [UpdateM IO ()] -> ClientM m ()
forall a b. (a -> b) -> a -> b
$ UpdateM IO () -> [UpdateM IO ()]
forall (m :: * -> *) a. Monad m => a -> m a
return (UpdateM IO () -> [UpdateM IO ()])
-> UpdateM IO () -> [UpdateM IO ()]
forall a b. (a -> b) -> a -> b
$ do
		[Project]
projects <- (Text -> UpdateM IO Project) -> [Text] -> UpdateM IO [Project]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Text -> UpdateM IO Project
forall (m :: * -> *). CommandMonad m => Text -> m Project
findProject [Text]
projs
		[Module]
projMods <- ([[Module]] -> [Module])
-> UpdateM IO [[Module]] -> UpdateM IO [Module]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[Module]] -> [Module]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (UpdateM IO [[Module]] -> UpdateM IO [Module])
-> UpdateM IO [[Module]] -> UpdateM IO [Module]
forall a b. (a -> b) -> a -> b
$ [Project]
-> (Project -> UpdateM IO [Module]) -> UpdateM IO [[Module]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Project]
projects ((Project -> UpdateM IO [Module]) -> UpdateM IO [[Module]])
-> (Project -> UpdateM IO [Module]) -> UpdateM IO [[Module]]
forall a b. (a -> b) -> a -> b
$ \Project
proj -> do
			[Module]
ms <- String -> Only Text -> UpdateM IO [Module]
forall (m :: * -> *) q.
(SessionMonad m, ToRow q) =>
String -> q -> m [Module]
loadModules String
"select id from modules where cabal == ? and json_extract(tags, '$.docs') is null"
				(Text -> Only Text
forall a. a -> Only a
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)
			Project
p <- Text -> UpdateM IO 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)
			[Module] -> UpdateM IO [Module]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Module] -> UpdateM IO [Module])
-> [Module] -> UpdateM IO [Module]
forall a b. (a -> b) -> a -> b
$ ASetter [Module] [Module] (Maybe Project) (Maybe Project)
-> Maybe Project -> [Module] -> [Module]
forall s t a b. ASetter s t a b -> b -> s -> t
set ((Module -> Identity Module) -> [Module] -> Identity [Module]
forall s t a b. Each s t a b => Traversal s t a b
each ((Module -> Identity Module) -> [Module] -> Identity [Module])
-> ((Maybe Project -> Identity (Maybe Project))
    -> Module -> Identity Module)
-> ASetter [Module] [Module] (Maybe Project) (Maybe Project)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleId -> Identity ModuleId) -> Module -> Identity Module
Lens' Module ModuleId
moduleId ((ModuleId -> Identity ModuleId) -> Module -> Identity Module)
-> ((Maybe Project -> Identity (Maybe Project))
    -> ModuleId -> Identity ModuleId)
-> (Maybe Project -> Identity (Maybe Project))
-> Module
-> Identity Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleLocation -> Identity ModuleLocation)
-> ModuleId -> Identity ModuleId
Lens' ModuleId ModuleLocation
moduleLocation ((ModuleLocation -> Identity ModuleLocation)
 -> ModuleId -> Identity ModuleId)
-> ((Maybe Project -> Identity (Maybe Project))
    -> ModuleLocation -> Identity ModuleLocation)
-> (Maybe Project -> Identity (Maybe Project))
-> ModuleId
-> Identity ModuleId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Project -> Identity (Maybe Project))
-> ModuleLocation -> Identity ModuleLocation
Traversal' ModuleLocation (Maybe Project)
moduleProject) (Project -> Maybe Project
forall a. a -> Maybe a
Just Project
p) [Module]
ms
		[Module]
fileMods <- ([[Module]] -> [Module])
-> UpdateM IO [[Module]] -> UpdateM IO [Module]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[Module]] -> [Module]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (UpdateM IO [[Module]] -> UpdateM IO [Module])
-> UpdateM IO [[Module]] -> UpdateM IO [Module]
forall a b. (a -> b) -> a -> b
$ [Text] -> (Text -> UpdateM IO [Module]) -> UpdateM IO [[Module]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Text]
fs ((Text -> UpdateM IO [Module]) -> UpdateM IO [[Module]])
-> (Text -> UpdateM IO [Module]) -> UpdateM IO [[Module]]
forall a b. (a -> b) -> a -> b
$ \Text
f ->
			String -> Only Text -> UpdateM IO [Module]
forall (m :: * -> *) q.
(SessionMonad m, ToRow q) =>
String -> q -> m [Module]
loadModules String
"select id from modules where file == ? and json_extract(tags, '$.docs') is null"
				(Text -> Only Text
forall a. a -> Only a
Only Text
f)
		[Module] -> UpdateM IO ()
forall (m :: * -> *). UpdateMonad m => [Module] -> m ()
Update.scanDocs ([Module] -> UpdateM IO ()) -> [Module] -> UpdateM IO ()
forall a b. (a -> b) -> a -> b
$ [Module]
projMods [Module] -> [Module] -> [Module]
forall a. [a] -> [a] -> [a]
++ [Module]
fileMods
	| Bool
otherwise = HsDevError -> ClientM m Value
forall (m :: * -> *) a. MonadThrow m => HsDevError -> m a
hsdevError (HsDevError -> ClientM m Value) -> HsDevError -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ String -> HsDevError
OtherError String
"docs not supported"
runCommand (InferTypes [Text]
projs [Text]
fs) = ClientM m () -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m () -> ClientM m Value)
-> ClientM m () -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ UpdateOptions -> [UpdateM IO ()] -> ClientM m ()
forall (m :: * -> *).
ServerMonadBase m =>
UpdateOptions -> [UpdateM IO ()] -> ClientM m ()
updateProcess UpdateOptions
forall a. Default a => a
def ([UpdateM IO ()] -> ClientM m ())
-> [UpdateM IO ()] -> ClientM m ()
forall a b. (a -> b) -> a -> b
$ UpdateM IO () -> [UpdateM IO ()]
forall (m :: * -> *) a. Monad m => a -> m a
return (UpdateM IO () -> [UpdateM IO ()])
-> UpdateM IO () -> [UpdateM IO ()]
forall a b. (a -> b) -> a -> b
$ do
	[Project]
projects <- (Text -> UpdateM IO Project) -> [Text] -> UpdateM IO [Project]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Text -> UpdateM IO Project
forall (m :: * -> *). CommandMonad m => Text -> m Project
findProject [Text]
projs
	[Module]
projMods <- ([[Module]] -> [Module])
-> UpdateM IO [[Module]] -> UpdateM IO [Module]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[Module]] -> [Module]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (UpdateM IO [[Module]] -> UpdateM IO [Module])
-> UpdateM IO [[Module]] -> UpdateM IO [Module]
forall a b. (a -> b) -> a -> b
$ [Project]
-> (Project -> UpdateM IO [Module]) -> UpdateM IO [[Module]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Project]
projects ((Project -> UpdateM IO [Module]) -> UpdateM IO [[Module]])
-> (Project -> UpdateM IO [Module]) -> UpdateM IO [[Module]]
forall a b. (a -> b) -> a -> b
$ \Project
proj -> do
		[Module]
ms <- String -> Only Text -> UpdateM IO [Module]
forall (m :: * -> *) q.
(SessionMonad m, ToRow q) =>
String -> q -> m [Module]
loadModules String
"select id from modules where cabal == ? and json_extract(tags, '$.types') is null"
			(Text -> Only Text
forall a. a -> Only a
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)
		Project
p <- Text -> UpdateM IO 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)
		[Module] -> UpdateM IO [Module]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Module] -> UpdateM IO [Module])
-> [Module] -> UpdateM IO [Module]
forall a b. (a -> b) -> a -> b
$ ASetter [Module] [Module] (Maybe Project) (Maybe Project)
-> Maybe Project -> [Module] -> [Module]
forall s t a b. ASetter s t a b -> b -> s -> t
set ((Module -> Identity Module) -> [Module] -> Identity [Module]
forall s t a b. Each s t a b => Traversal s t a b
each ((Module -> Identity Module) -> [Module] -> Identity [Module])
-> ((Maybe Project -> Identity (Maybe Project))
    -> Module -> Identity Module)
-> ASetter [Module] [Module] (Maybe Project) (Maybe Project)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleId -> Identity ModuleId) -> Module -> Identity Module
Lens' Module ModuleId
moduleId ((ModuleId -> Identity ModuleId) -> Module -> Identity Module)
-> ((Maybe Project -> Identity (Maybe Project))
    -> ModuleId -> Identity ModuleId)
-> (Maybe Project -> Identity (Maybe Project))
-> Module
-> Identity Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleLocation -> Identity ModuleLocation)
-> ModuleId -> Identity ModuleId
Lens' ModuleId ModuleLocation
moduleLocation ((ModuleLocation -> Identity ModuleLocation)
 -> ModuleId -> Identity ModuleId)
-> ((Maybe Project -> Identity (Maybe Project))
    -> ModuleLocation -> Identity ModuleLocation)
-> (Maybe Project -> Identity (Maybe Project))
-> ModuleId
-> Identity ModuleId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Project -> Identity (Maybe Project))
-> ModuleLocation -> Identity ModuleLocation
Traversal' ModuleLocation (Maybe Project)
moduleProject) (Project -> Maybe Project
forall a. a -> Maybe a
Just Project
p) [Module]
ms
	[Module]
fileMods <- ([[Module]] -> [Module])
-> UpdateM IO [[Module]] -> UpdateM IO [Module]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[Module]] -> [Module]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (UpdateM IO [[Module]] -> UpdateM IO [Module])
-> UpdateM IO [[Module]] -> UpdateM IO [Module]
forall a b. (a -> b) -> a -> b
$ [Text] -> (Text -> UpdateM IO [Module]) -> UpdateM IO [[Module]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Text]
fs ((Text -> UpdateM IO [Module]) -> UpdateM IO [[Module]])
-> (Text -> UpdateM IO [Module]) -> UpdateM IO [[Module]]
forall a b. (a -> b) -> a -> b
$ \Text
f ->
		String -> Only Text -> UpdateM IO [Module]
forall (m :: * -> *) q.
(SessionMonad m, ToRow q) =>
String -> q -> m [Module]
loadModules String
"select id from modules where file == ? and json_extract(tags, '$.types') is null"
			(Text -> Only Text
forall a. a -> Only a
Only Text
f)
	[Module] -> UpdateM IO ()
forall (m :: * -> *). UpdateMonad m => [Module] -> m ()
Update.inferModTypes ([Module] -> UpdateM IO ()) -> [Module] -> UpdateM IO ()
forall a b. (a -> b) -> a -> b
$ [Module]
projMods [Module] -> [Module] -> [Module]
forall a. [a] -> [a] -> [a]
++ [Module]
fileMods
runCommand (Remove [Text]
projs Bool
cabal [Text]
sboxes [Text]
files) = ClientM m () -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m () -> ClientM m Value)
-> ClientM m () -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ ClientM m () -> ClientM m ()
forall (m :: * -> *) a. SessionMonad m => m a -> m a
withSqlConnection (ClientM m () -> ClientM m ()) -> ClientM m () -> ClientM m ()
forall a b. (a -> b) -> a -> b
$ TransactionType -> ClientM m () -> ClientM m ()
forall (m :: * -> *) a.
SessionMonad m =>
TransactionType -> m a -> m a
SQLite.transaction_ TransactionType
SQLite.Immediate (ClientM m () -> ClientM m ()) -> ClientM m () -> ClientM m ()
forall a b. (a -> b) -> a -> b
$ do
	let
		-- We can safely remove package-db from db iff doesn't used by some of other package-dbs
		-- For example, we can't remove global-db if there are any other package-dbs, because all of them uses global-db
		-- We also can't remove stack snapshot package-db if there are some local package-db not yet removed
		canRemove :: PackageDbStack -> m Bool
canRemove PackageDbStack
pdbs = do
			[PackageDbStack]
from' <- m [PackageDbStack]
forall s (m :: * -> *). MonadState s m => m s
State.get
			Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ [PackageDbStack] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([PackageDbStack] -> Bool) -> [PackageDbStack] -> Bool
forall a b. (a -> b) -> a -> b
$ (PackageDbStack -> Bool) -> [PackageDbStack] -> [PackageDbStack]
forall a. (a -> Bool) -> [a] -> [a]
filter (PackageDbStack
pdbs PackageDbStack -> PackageDbStack -> Bool
`isSubStack`) ([PackageDbStack] -> [PackageDbStack])
-> [PackageDbStack] -> [PackageDbStack]
forall a b. (a -> b) -> a -> b
$ PackageDbStack -> [PackageDbStack] -> [PackageDbStack]
forall a. Eq a => a -> [a] -> [a]
delete PackageDbStack
pdbs [PackageDbStack]
from'
		-- Remove top of package-db stack if possible
		removePackageDb' :: PackageDbStack -> m ()
removePackageDb' PackageDbStack
pdbs = do
			Bool
can <- PackageDbStack -> m Bool
forall (m :: * -> *).
MonadState [PackageDbStack] m =>
PackageDbStack -> m Bool
canRemove PackageDbStack
pdbs
			Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
can (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
				([PackageDbStack] -> [PackageDbStack]) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (PackageDbStack -> [PackageDbStack] -> [PackageDbStack]
forall a. Eq a => a -> [a] -> [a]
delete PackageDbStack
pdbs)
				[Int]
ms <- ([Only Int] -> [Int]) -> m [Only Int] -> m [Int]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((Only Int -> Int) -> [Only Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Only Int -> Int
forall a. Only a -> a
fromOnly) (m [Only Int] -> m [Int]) -> m [Only Int] -> m [Int]
forall a b. (a -> b) -> a -> b
$ Query -> m [Only Int]
forall r (m :: * -> *).
(FromRow r, SessionMonad m) =>
Query -> m [r]
query_
					Query
"select m.id from modules as m, package_dbs as ps where m.package_name == ps.package_name and m.package_version == ps.package_version;"
				PackageDb -> m ()
forall (m :: * -> *). SessionMonad m => PackageDb -> m ()
removePackageDb (PackageDbStack -> PackageDb
topPackageDb PackageDbStack
pdbs)
				(Int -> m ()) -> [Int] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Int -> m ()
forall (m :: * -> *). SessionMonad m => Int -> m ()
SQLite.removeModule [Int]
ms
				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
$ \Watcher
w ->
					IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Watcher -> PackageDb -> IO ()
unwatchPackageDb Watcher
w (PackageDb -> IO ()) -> PackageDb -> IO ()
forall a b. (a -> b) -> a -> b
$ PackageDbStack -> PackageDb
topPackageDb PackageDbStack
pdbs
		-- Remove package-db stack when possible
		removePackageDbStack :: PackageDbStack -> StateT [PackageDbStack] (ClientM m) ()
removePackageDbStack = (PackageDbStack -> StateT [PackageDbStack] (ClientM m) ())
-> [PackageDbStack] -> StateT [PackageDbStack] (ClientM m) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ PackageDbStack -> StateT [PackageDbStack] (ClientM m) ()
forall (m :: * -> *).
(MonadState [PackageDbStack] m, SessionMonad m) =>
PackageDbStack -> m ()
removePackageDb' ([PackageDbStack] -> StateT [PackageDbStack] (ClientM m) ())
-> (PackageDbStack -> [PackageDbStack])
-> PackageDbStack
-> StateT [PackageDbStack] (ClientM m) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageDbStack -> [PackageDbStack]
packageDbStacks
	[Project]
projects <- (Text -> ClientM m Project) -> [Text] -> ClientM m [Project]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Text -> ClientM m Project
forall (m :: * -> *). CommandMonad m => Text -> m Project
findProject [Text]
projs
	[Sandbox]
sboxes' <- [Text] -> ClientM m [Sandbox]
forall (m :: * -> *). CommandMonad m => [Text] -> m [Sandbox]
getSandboxes [Text]
sboxes
	[Project] -> (Project -> ClientM m ()) -> ClientM m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Project]
projects ((Project -> ClientM m ()) -> ClientM m ())
-> (Project -> ClientM m ()) -> ClientM m ()
forall a b. (a -> b) -> a -> b
$ \Project
proj -> do
		[Int]
ms <- ([Only Int] -> [Int]) -> ClientM m [Only Int] -> ClientM m [Int]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((Only Int -> Int) -> [Only Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Only Int -> Int
forall a. Only a -> a
fromOnly) (ClientM m [Only Int] -> ClientM m [Int])
-> ClientM m [Only Int] -> ClientM m [Int]
forall a b. (a -> b) -> a -> b
$ Query -> Only Text -> ClientM m [Only Int]
forall q r (m :: * -> *).
(ToRow q, FromRow r, SessionMonad m) =>
Query -> q -> m [r]
query Query
"select id from modules where cabal == ?;" (Text -> Only Text
forall a. a -> Only a
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)
		Project -> ClientM m ()
forall (m :: * -> *). SessionMonad m => Project -> m ()
SQLite.removeProject Project
proj
		(Int -> ClientM m ()) -> [Int] -> ClientM m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Int -> ClientM m ()
forall (m :: * -> *). SessionMonad m => Int -> m ()
SQLite.removeModule [Int]
ms
		ClientM m (Maybe Watcher)
-> (Watcher -> ClientM m ()) -> ClientM m ()
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m b) -> m ()
whenJustM ((Session -> Maybe Watcher) -> ClientM m (Maybe Watcher)
forall (m :: * -> *) a. SessionMonad m => (Session -> a) -> m a
askSession Session -> Maybe Watcher
sessionWatcher) ((Watcher -> ClientM m ()) -> ClientM m ())
-> (Watcher -> ClientM m ()) -> ClientM m ()
forall a b. (a -> b) -> a -> b
$ \Watcher
w ->
			IO () -> ClientM m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ClientM m ()) -> IO () -> ClientM m ()
forall a b. (a -> b) -> a -> b
$ Watcher -> Project -> IO ()
unwatchProject Watcher
w Project
proj

	[PackageDb]
allPdbs <- ([Only PackageDb] -> [PackageDb])
-> ClientM m [Only PackageDb] -> ClientM m [PackageDb]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((Only PackageDb -> PackageDb) -> [Only PackageDb] -> [PackageDb]
forall a b. (a -> b) -> [a] -> [b]
map Only PackageDb -> PackageDb
forall a. Only a -> a
fromOnly) (ClientM m [Only PackageDb] -> ClientM m [PackageDb])
-> ClientM m [Only PackageDb] -> ClientM m [PackageDb]
forall a b. (a -> b) -> a -> b
$ Query -> ClientM m [Only PackageDb]
forall r (m :: * -> *).
(FromRow r, SessionMonad m) =>
Query -> m [r]
query_ @(Only PackageDb) Query
"select package_db from package_dbs;"
	[PackageDbStack]
dbPDbs <- GhcM [PackageDbStack] -> ClientM m [PackageDbStack]
forall (m :: * -> *) a. SessionMonad m => GhcM a -> m a
inSessionGhc (GhcM [PackageDbStack] -> ClientM m [PackageDbStack])
-> GhcM [PackageDbStack] -> ClientM m [PackageDbStack]
forall a b. (a -> b) -> a -> b
$ (PackageDb
 -> MGhcT SessionConfig (First DynFlags) (LogT IO) PackageDbStack)
-> [PackageDb] -> GhcM [PackageDbStack]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM PackageDb
-> MGhcT SessionConfig (First DynFlags) (LogT IO) PackageDbStack
restorePackageDbStack [PackageDb]
allPdbs
	(StateT [PackageDbStack] (ClientM m) ()
 -> [PackageDbStack] -> ClientM m ())
-> [PackageDbStack]
-> StateT [PackageDbStack] (ClientM m) ()
-> ClientM m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT [PackageDbStack] (ClientM m) ()
-> [PackageDbStack] -> ClientM m ()
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
State.evalStateT [PackageDbStack]
dbPDbs (StateT [PackageDbStack] (ClientM m) () -> ClientM m ())
-> StateT [PackageDbStack] (ClientM m) () -> ClientM m ()
forall a b. (a -> b) -> a -> b
$ do
		Bool
-> StateT [PackageDbStack] (ClientM m) ()
-> StateT [PackageDbStack] (ClientM m) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
cabal (StateT [PackageDbStack] (ClientM m) ()
 -> StateT [PackageDbStack] (ClientM m) ())
-> StateT [PackageDbStack] (ClientM m) ()
-> StateT [PackageDbStack] (ClientM m) ()
forall a b. (a -> b) -> a -> b
$ PackageDbStack -> StateT [PackageDbStack] (ClientM m) ()
removePackageDbStack PackageDbStack
userDb
		[Sandbox]
-> (Sandbox -> StateT [PackageDbStack] (ClientM m) ())
-> StateT [PackageDbStack] (ClientM m) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Sandbox]
sboxes' ((Sandbox -> StateT [PackageDbStack] (ClientM m) ())
 -> StateT [PackageDbStack] (ClientM m) ())
-> (Sandbox -> StateT [PackageDbStack] (ClientM m) ())
-> StateT [PackageDbStack] (ClientM m) ()
forall a b. (a -> b) -> a -> b
$ \Sandbox
sbox -> do
			PackageDbStack
pdbs <- ClientM m PackageDbStack
-> StateT [PackageDbStack] (ClientM m) PackageDbStack
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ClientM m PackageDbStack
 -> StateT [PackageDbStack] (ClientM m) PackageDbStack)
-> ClientM m PackageDbStack
-> StateT [PackageDbStack] (ClientM m) PackageDbStack
forall a b. (a -> b) -> a -> b
$ MGhcT SessionConfig (First DynFlags) (LogT IO) PackageDbStack
-> ClientM m PackageDbStack
forall (m :: * -> *) a. SessionMonad m => GhcM a -> m a
inSessionGhc (MGhcT SessionConfig (First DynFlags) (LogT IO) PackageDbStack
 -> ClientM m PackageDbStack)
-> MGhcT SessionConfig (First DynFlags) (LogT IO) PackageDbStack
-> ClientM m PackageDbStack
forall a b. (a -> b) -> a -> b
$ Sandbox
-> MGhcT SessionConfig (First DynFlags) (LogT IO) PackageDbStack
sandboxPackageDbStack Sandbox
sbox
			PackageDbStack -> StateT [PackageDbStack] (ClientM m) ()
removePackageDbStack PackageDbStack
pdbs

	[Text] -> (Text -> ClientM m ()) -> ClientM m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Text]
files ((Text -> ClientM m ()) -> ClientM m ())
-> (Text -> ClientM m ()) -> ClientM m ()
forall a b. (a -> b) -> a -> b
$ \Text
file -> do
		[ModuleId :. Only Int]
ms <- Query -> Only Text -> ClientM m [ModuleId :. Only Int]
forall q r (m :: * -> *).
(ToRow q, FromRow r, SessionMonad m) =>
Query -> q -> m [r]
query @_ @(ModuleId :. Only Int)
			(Select Text -> Query
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 [
				Select Text
qModuleId,
				[Text] -> Select Text
forall a. [a] -> Select a
select_ [Text
"mu.id"],
				[Text] -> Select Text
forall a. [a] -> Select a
where_ [Text
"mu.file == ?"]])
			(Text -> Only Text
forall a. a -> Only a
Only Text
file)
		[ModuleId :. Only Int]
-> ((ModuleId :. Only Int) -> ClientM m ()) -> ClientM m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ModuleId :. Only Int]
ms (((ModuleId :. Only Int) -> ClientM m ()) -> ClientM m ())
-> ((ModuleId :. Only Int) -> ClientM m ()) -> ClientM m ()
forall a b. (a -> b) -> a -> b
$ \(ModuleId
m :. Only Int
i) -> do
			Int -> ClientM m ()
forall (m :: * -> *). SessionMonad m => Int -> m ()
SQLite.removeModule Int
i
			ClientM m (Maybe Watcher)
-> (Watcher -> ClientM m ()) -> ClientM m ()
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m b) -> m ()
whenJustM ((Session -> Maybe Watcher) -> ClientM m (Maybe Watcher)
forall (m :: * -> *) a. SessionMonad m => (Session -> a) -> m a
askSession Session -> Maybe Watcher
sessionWatcher) ((Watcher -> ClientM m ()) -> ClientM m ())
-> (Watcher -> ClientM m ()) -> ClientM m ()
forall a b. (a -> b) -> a -> b
$ \Watcher
w ->
				IO () -> ClientM m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ClientM m ())
-> (ModuleLocation -> IO ()) -> ModuleLocation -> ClientM m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Watcher -> ModuleLocation -> IO ()
unwatchModule Watcher
w (ModuleLocation -> ClientM m ()) -> ModuleLocation -> ClientM m ()
forall a b. (a -> b) -> a -> b
$ (ModuleId
m ModuleId
-> Getting ModuleLocation ModuleId ModuleLocation -> ModuleLocation
forall s a. s -> Getting a s a -> a
^. Getting ModuleLocation ModuleId ModuleLocation
Lens' ModuleId ModuleLocation
moduleLocation)
runCommand Command
RemoveAll = ClientM m () -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m () -> ClientM m Value)
-> ClientM m () -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ do
	ClientM m ()
forall (m :: * -> *). SessionMonad m => m ()
SQLite.purge
	ClientM m (Maybe Watcher)
-> (Watcher -> ClientM m ()) -> ClientM m ()
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m b) -> m ()
whenJustM ((Session -> Maybe Watcher) -> ClientM m (Maybe Watcher)
forall (m :: * -> *) a. SessionMonad m => (Session -> a) -> m a
askSession Session -> Maybe Watcher
sessionWatcher) ((Watcher -> ClientM m ()) -> ClientM m ())
-> (Watcher -> ClientM m ()) -> ClientM m ()
forall a b. (a -> b) -> a -> b
$ \Watcher
w -> do
		Map String (Bool, IO ())
wdirs <- IO (Map String (Bool, IO ()))
-> ClientM m (Map String (Bool, IO ()))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map String (Bool, IO ()))
 -> ClientM m (Map String (Bool, IO ())))
-> IO (Map String (Bool, IO ()))
-> ClientM m (Map String (Bool, IO ()))
forall a b. (a -> b) -> a -> b
$ MVar (Map String (Bool, IO ())) -> IO (Map String (Bool, IO ()))
forall a. MVar a -> IO a
readMVar (Watcher -> MVar (Map String (Bool, IO ()))
forall a. Watcher a -> MVar (Map String (Bool, IO ()))
W.watcherDirs Watcher
w)
		IO () -> ClientM m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ClientM m ()) -> IO () -> ClientM m ()
forall a b. (a -> b) -> a -> b
$ [(String, (Bool, IO ()))]
-> ((String, (Bool, IO ())) -> IO Bool) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map String (Bool, IO ()) -> [(String, (Bool, IO ()))]
forall k a. Map k a -> [(k, a)]
M.toList Map String (Bool, IO ())
wdirs) (((String, (Bool, IO ())) -> IO Bool) -> IO ())
-> ((String, (Bool, IO ())) -> IO Bool) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(String
dir, (Bool
isTree, IO ()
_)) -> (if Bool
isTree then Watcher -> String -> IO Bool
forall a. Watcher a -> String -> IO Bool
W.unwatchTree else Watcher -> String -> IO Bool
forall a. Watcher a -> String -> IO Bool
W.unwatchDir) Watcher
w String
dir
runCommand Command
InfoPackages = ClientM m [ModulePackage] -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m [ModulePackage] -> ClientM m Value)
-> ClientM m [ModulePackage] -> ClientM m Value
forall a b. (a -> b) -> a -> b
$
	Query -> ClientM m [ModulePackage]
forall r (m :: * -> *).
(FromRow r, SessionMonad m) =>
Query -> m [r]
query_ @ModulePackage Query
"select package_name, package_version from package_dbs;"
runCommand Command
InfoProjects = ClientM m [Project] -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m [Project] -> ClientM m Value)
-> ClientM m [Project] -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ do
	[Only Text]
ps <- Query -> ClientM m [Only Text]
forall r (m :: * -> *).
(FromRow r, SessionMonad m) =>
Query -> m [r]
query_ @(Only Path) Query
"select cabal from projects;"
	(Only Text -> ClientM m Project)
-> [Only Text] -> ClientM m [Project]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Text -> ClientM m Project
forall (m :: * -> *). SessionMonad m => Text -> m Project
SQLite.loadProject (Text -> ClientM m Project)
-> (Only Text -> Text) -> Only Text -> ClientM m Project
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Only Text -> Text
forall a. Only a -> a
fromOnly) [Only Text]
ps
runCommand Command
InfoSandboxes = ClientM m [PackageDb] -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m [PackageDb] -> ClientM m Value)
-> ClientM m [PackageDb] -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ do
	[Only PackageDb]
rs <- Query -> ClientM m [Only PackageDb]
forall r (m :: * -> *).
(FromRow r, SessionMonad m) =>
Query -> m [r]
query_ @(Only PackageDb) Query
"select distinct package_db from package_dbs;"
	[PackageDb] -> ClientM m [PackageDb]
forall (m :: * -> *) a. Monad m => a -> m a
return [PackageDb
pdb | Only PackageDb
pdb <- [Only PackageDb]
rs]
runCommand (InfoSymbol SearchQuery
sq [TargetFilter]
filters Bool
True Bool
_) = ClientM m [SymbolId] -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m [SymbolId] -> ClientM m Value)
-> ClientM m [SymbolId] -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ do
	let
		([Text]
conds, [NamedParam]
params) = Text -> Maybe Text -> [TargetFilter] -> ([Text], [NamedParam])
targetFilters Text
"m" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"s") [TargetFilter]
filters
	Query -> [NamedParam] -> ClientM m [SymbolId]
forall r (m :: * -> *).
(FromRow r, SessionMonad m) =>
Query -> [NamedParam] -> m [r]
queryNamed @SymbolId
		(Select Text -> Query
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 [
			Select Text
qSymbolId,
			[Text] -> Select Text
forall a. [a] -> Select a
where_ [Text
"s.name like :pattern escape '\\'"],
			[Text] -> Select Text
forall a. [a] -> Select a
where_ [Text]
conds])
		([Text
":pattern" Text -> Text -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= SearchQuery -> Text
likePattern SearchQuery
sq] [NamedParam] -> [NamedParam] -> [NamedParam]
forall a. [a] -> [a] -> [a]
++ [NamedParam]
params)
runCommand (InfoSymbol SearchQuery
sq [TargetFilter]
filters Bool
False Bool
_) = ClientM m [Symbol] -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m [Symbol] -> ClientM m Value)
-> ClientM m [Symbol] -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ do
	let
		([Text]
conds, [NamedParam]
params) = Text -> Maybe Text -> [TargetFilter] -> ([Text], [NamedParam])
targetFilters Text
"m" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"s") [TargetFilter]
filters
	Query -> [NamedParam] -> ClientM m [Symbol]
forall r (m :: * -> *).
(FromRow r, SessionMonad m) =>
Query -> [NamedParam] -> m [r]
queryNamed @Symbol
		(Select Text -> Query
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 [
			Select Text
qSymbol,
			[Text] -> Select Text
forall a. [a] -> Select a
where_ [Text
"s.name like :pattern escape '\\'"],
			[Text] -> Select Text
forall a. [a] -> Select a
where_ [Text]
conds])
		([Text
":pattern" Text -> Text -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= SearchQuery -> Text
likePattern SearchQuery
sq] [NamedParam] -> [NamedParam] -> [NamedParam]
forall a. [a] -> [a] -> [a]
++ [NamedParam]
params)
runCommand (InfoModule SearchQuery
sq [TargetFilter]
filters Bool
h Bool
_) = ClientM m Value -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m Value -> ClientM m Value)
-> ClientM m Value -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ do
	let
		([Text]
conds, [NamedParam]
params) = Text -> Maybe Text -> [TargetFilter] -> ([Text], [NamedParam])
targetFilters Text
"mu" Maybe Text
forall a. Maybe a
Nothing [TargetFilter]
filters
	[Only Int :. ModuleId]
rs <- Query -> [NamedParam] -> ClientM m [Only Int :. ModuleId]
forall r (m :: * -> *).
(FromRow r, SessionMonad m) =>
Query -> [NamedParam] -> m [r]
queryNamed @(Only Int :. ModuleId)
		(Select Text -> Query
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] -> Select Text
forall a. [a] -> Select a
select_ [Text
"mu.id"],
			Select Text
qModuleId,
			[Text] -> Select Text
forall a. [a] -> Select a
where_ [Text
"mu.name like :pattern escape '\\'"],
			[Text] -> Select Text
forall a. [a] -> Select a
where_ [Text]
conds])
		([Text
":pattern" Text -> Text -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= SearchQuery -> Text
likePattern SearchQuery
sq] [NamedParam] -> [NamedParam] -> [NamedParam]
forall a. [a] -> [a] -> [a]
++ [NamedParam]
params)
	if Bool
h
		then Value -> ClientM m Value
forall (m :: * -> *) a. Monad m => a -> m a
return ([ModuleId] -> Value
forall a. ToJSON a => a -> Value
toJSON ([ModuleId] -> Value) -> [ModuleId] -> Value
forall a b. (a -> b) -> a -> b
$ ((Only Int :. ModuleId) -> ModuleId)
-> [Only Int :. ModuleId] -> [ModuleId]
forall a b. (a -> b) -> [a] -> [b]
map (\(Only Int
_ :. ModuleId
m) -> ModuleId
m) [Only Int :. ModuleId]
rs)
		else ([Module] -> Value) -> ClientM m [Module] -> ClientM m Value
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Module] -> Value
forall a. ToJSON a => a -> Value
toJSON (ClientM m [Module] -> ClientM m Value)
-> ClientM m [Module] -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ [Only Int :. ModuleId]
-> ((Only Int :. ModuleId) -> ClientM m Module)
-> ClientM m [Module]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Only Int :. ModuleId]
rs (((Only Int :. ModuleId) -> ClientM m Module)
 -> ClientM m [Module])
-> ((Only Int :. ModuleId) -> ClientM m Module)
-> ClientM m [Module]
forall a b. (a -> b) -> a -> b
$ \(Only Int
mid :. ModuleId
mheader) -> do
			[(Maybe Text
docs, Maybe Value
fixities)] <- Query -> Only Int -> ClientM m [(Maybe Text, Maybe Value)]
forall q r (m :: * -> *).
(ToRow q, FromRow r, SessionMonad m) =>
Query -> q -> m [r]
query @_ @(Maybe Text, Maybe Value) Query
"select m.docs, m.fixities from modules as m where (m.id == ?);"
				(Int -> Only Int
forall a. a -> Only a
Only Int
mid)
			let
				fixities' :: [Fixity]
fixities' = [Fixity] -> Maybe [Fixity] -> [Fixity]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe Value
fixities Maybe Value -> (Value -> Maybe [Fixity]) -> Maybe [Fixity]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Maybe [Fixity]
forall a. FromJSON a => Value -> Maybe a
fromJSON')
			[Import]
imports' <- Query -> Only Int -> ClientM m [Import]
forall q r (m :: * -> *).
(ToRow q, FromRow r, SessionMonad m) =>
Query -> q -> m [r]
query @_ @Import (Select Text -> Query
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 -> Select Text
qImport Text
"i",
				[Text] -> Select Text
forall a. [a] -> Select a
where_ [Text
"i.module_id = ?"]])
				(Int -> Only Int
forall a. a -> Only a
Only Int
mid)
			[Symbol]
exports' <- Query -> Only Int -> ClientM m [Symbol]
forall q r (m :: * -> *).
(ToRow q, FromRow r, SessionMonad m) =>
Query -> q -> m [r]
query @_ @Symbol (Select Text -> Query
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 [
				Select Text
qSymbol,
				[Text] -> Select Text
forall a. [a] -> Select a
from_ [Text
"exports as e"],
				[Text] -> Select Text
forall a. [a] -> Select a
where_ [Text
"e.module_id == ?", Text
"e.symbol_id == s.id"]])
				(Int -> Only Int
forall a. a -> Only a
Only Int
mid)
			Module -> ClientM m Module
forall (m :: * -> *) a. Monad m => a -> m a
return (Module -> ClientM m Module) -> Module -> ClientM m Module
forall a b. (a -> b) -> a -> b
$ ModuleId
-> Maybe Text
-> [Import]
-> [Symbol]
-> [Fixity]
-> Map Name [Symbol]
-> Maybe Parsed
-> Module
Module ModuleId
mheader Maybe Text
docs [Import]
imports' [Symbol]
exports' [Fixity]
fixities' Map Name [Symbol]
forall a. Monoid a => a
mempty Maybe Parsed
forall a. Maybe a
Nothing
runCommand (InfoProject (Left Text
projName)) = ClientM m Project -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m Project -> ClientM m Value)
-> ClientM m Project -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ Text -> ClientM m Project
forall (m :: * -> *). CommandMonad m => Text -> m Project
findProject Text
projName
runCommand (InfoProject (Right Text
projPath)) = ClientM m (Maybe Project) -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m (Maybe Project) -> ClientM m Value)
-> ClientM m (Maybe Project) -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ IO (Maybe Project) -> ClientM m (Maybe Project)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Project) -> ClientM m (Maybe Project))
-> IO (Maybe Project) -> ClientM m (Maybe Project)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe Project)
searchProject (Getting String Text String -> Text -> String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting String Text String
Lens' Text String
path Text
projPath)
runCommand (InfoSandbox Text
sandbox') = ClientM m [Sandbox] -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m [Sandbox] -> ClientM m Value)
-> ClientM m [Sandbox] -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ IO [Sandbox] -> ClientM m [Sandbox]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Sandbox] -> ClientM m [Sandbox])
-> IO [Sandbox] -> ClientM m [Sandbox]
forall a b. (a -> b) -> a -> b
$ Text -> IO [Sandbox]
searchSandboxes Text
sandbox'
runCommand (Lookup Text
nm Text
fpath) = ClientM m [ImportedSymbol] -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m [ImportedSymbol] -> ClientM m Value)
-> ClientM m [ImportedSymbol] -> ClientM m Value
forall a b. (a -> b) -> a -> b
$
	([Symbol :. ModuleId] -> [ImportedSymbol])
-> ClientM m [Symbol :. ModuleId] -> ClientM m [ImportedSymbol]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Symbol :. ModuleId) -> ImportedSymbol)
-> [Symbol :. ModuleId] -> [ImportedSymbol]
forall a b. (a -> b) -> [a] -> [b]
map (\(Symbol
s :. ModuleId
m) -> Symbol -> ModuleId -> ImportedSymbol
ImportedSymbol Symbol
s ModuleId
m)) (ClientM m [Symbol :. ModuleId] -> ClientM m [ImportedSymbol])
-> ClientM m [Symbol :. ModuleId] -> ClientM m [ImportedSymbol]
forall a b. (a -> b) -> a -> b
$ Query -> (String, Text) -> ClientM m [Symbol :. ModuleId]
forall q r (m :: * -> *).
(ToRow q, FromRow r, SessionMonad m) =>
Query -> q -> m [r]
query @_ @(Symbol :. ModuleId) (Select Text -> Query
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 [
		Select Text
qSymbol,
		Select Text
qModuleId,
		[Text] -> Select Text
forall a. [a] -> Select a
from_ [Text
"projects_modules_scope as pms", Text
"modules as srcm", Text
"exports as e"],
		[Text] -> Select Text
forall a. [a] -> Select a
where_ [
			Text
"pms.cabal is srcm.cabal",
			Text
"srcm.file = ?",
			Text
"pms.module_id = e.module_id",
			Text
"m.id = s.module_id",
			Text
"s.id = e.symbol_id",
			Text
"e.module_id = mu.id",
			Text
"s.name = ?"]])
		(Text
fpath Text -> Getting String Text String -> String
forall s a. s -> Getting a s a -> a
^. Getting String Text String
Lens' Text String
path, Text
nm)
runCommand (Whois Text
nm Text
fpath) = ClientM m [Symbol] -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m [Symbol] -> ClientM m Value)
-> ClientM m [Symbol] -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ do
	let
		q :: Maybe Text
q = Name -> Maybe Text
nameModule (Name -> Maybe Text) -> Name -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text -> Name
toName Text
nm
		ident :: Text
ident = Name -> Text
nameIdent (Name -> Text) -> Name -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Name
toName Text
nm
	Query -> (String, Maybe Text, Text) -> ClientM m [Symbol]
forall q r (m :: * -> *).
(ToRow q, FromRow r, SessionMonad m) =>
Query -> q -> m [r]
query @_ @Symbol (Select Text -> Query
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 [
		Select Text
qSymbol,
		[Text] -> Select Text
forall a. [a] -> Select a
from_ [Text
"modules as srcm", Text
"scopes as sc"],
		[Text] -> Select Text
forall a. [a] -> Select a
where_ [
			Text
"srcm.id == sc.module_id",
			Text
"s.id == sc.symbol_id",
			Text
"srcm.file == ?",
			Text
"sc.qualifier is ?",
			Text
"sc.name == ?"]])
		(Text
fpath Text -> Getting String Text String -> String
forall s a. s -> Getting a s a -> a
^. Getting String Text String
Lens' Text String
path, Maybe Text
q, Text
ident)
runCommand (Whoat Int
l Int
c Text
fpath) = ClientM m [Symbol] -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m [Symbol] -> ClientM m Value)
-> ClientM m [Symbol] -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ do
	[Symbol]
rs <- Query -> (String, Int, Int) -> ClientM m [Symbol]
forall q r (m :: * -> *).
(ToRow q, FromRow r, SessionMonad m) =>
Query -> q -> m [r]
query @_ @Symbol (Select Text -> Query
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 [
		Select Text
qSymbol,
		[Text] -> Select Text
forall a. [a] -> Select a
from_ [Text
"names as n", Text
"modules as srcm"],
		[Text] -> Select Text
forall a. [a] -> Select a
where_ [
			Text
"srcm.id == n.module_id",
			Text
"m.name == n.resolved_module",
			Text
"s.name == n.resolved_name",
			Text
"s.what == n.resolved_what",
			Text
"s.id == n.symbol_id",
			Text
"srcm.file == ?",
			Text
"(?, ?) between (n.line, n.column) and (n.line_to, n.column_to)"]])
		(Text
fpath Text -> Getting String Text String -> String
forall s a. s -> Getting a s a -> a
^. Getting String Text String
Lens' Text String
path, Int
l, Int
c)
	[Symbol]
locals <- do
		[ModuleId :. (Text, Int, Int, Maybe Text)]
defs <- Query
-> (String, Int, Int)
-> ClientM m [ModuleId :. (Text, Int, Int, Maybe Text)]
forall q r (m :: * -> *).
(ToRow q, FromRow r, SessionMonad m) =>
Query -> q -> m [r]
query @_ @(ModuleId :. (Text, Int, Int, Maybe Text)) (Select Text -> Query
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 [
			Select Text
qModuleId,
			[Text] -> Select Text
forall a. [a] -> Select a
select_ [Text
"n.name", Text
"n.def_line", Text
"n.def_column", Text
"n.inferred_type"],
			[Text] -> Select Text
forall a. [a] -> Select a
from_ [Text
"names as n"],
			[Text] -> Select Text
forall a. [a] -> Select a
where_ [
				Text
"mu.id == n.module_id",
				Text
"n.def_line is not null",
				Text
"n.def_column is not null",
				Text
"mu.file == ?",
				Text
"(?, ?) between (n.line, n.column) and (n.line_to, n.column_to)"]])
			(Text
fpath Text -> Getting String Text String -> String
forall s a. s -> Getting a s a -> a
^. Getting String Text String
Lens' Text String
path, Int
l, Int
c)
		[Symbol] -> ClientM m [Symbol]
forall (m :: * -> *) a. Monad m => a -> m a
return [
			Symbol :: SymbolId -> Maybe Text -> Maybe Position -> SymbolInfo -> Symbol
Symbol {
				_symbolId :: SymbolId
_symbolId = Text -> ModuleId -> SymbolId
SymbolId Text
nm ModuleId
mid,
				_symbolDocs :: Maybe Text
_symbolDocs = Maybe Text
forall a. Maybe a
Nothing,
				_symbolPosition :: Maybe Position
_symbolPosition = Position -> Maybe Position
forall a. a -> Maybe a
Just (Int -> Int -> Position
Position Int
defLine Int
defColumn),
				_symbolInfo :: SymbolInfo
_symbolInfo = Maybe Text -> SymbolInfo
Function Maybe Text
ftype
			} | (ModuleId
mid :. (Text
nm, Int
defLine, Int
defColumn, Maybe Text
ftype)) <- [ModuleId :. (Text, Int, Int, Maybe Text)]
defs]
	[Symbol] -> ClientM m [Symbol]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Symbol] -> ClientM m [Symbol]) -> [Symbol] -> ClientM m [Symbol]
forall a b. (a -> b) -> a -> b
$ [Symbol]
rs [Symbol] -> [Symbol] -> [Symbol]
forall a. [a] -> [a] -> [a]
++ [Symbol]
locals
runCommand (ResolveScopeModules SearchQuery
sq Text
fpath) = ClientM m [ModuleId] -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m [ModuleId] -> ClientM m Value)
-> ClientM m [ModuleId] -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ do
	[Only (Maybe Text)]
pids <- Query -> Only String -> ClientM m [Only (Maybe Text)]
forall q r (m :: * -> *).
(ToRow q, FromRow r, SessionMonad m) =>
Query -> q -> m [r]
query @_ @(Only (Maybe Path)) Query
"select m.cabal from modules as m where (m.file == ?);"
		(String -> Only String
forall a. a -> Only a
Only (String -> Only String) -> String -> Only String
forall a b. (a -> b) -> a -> b
$ Text
fpath Text -> Getting String Text String -> String
forall s a. s -> Getting a s a -> a
^. Getting String Text String
Lens' Text String
path)
	case [Only (Maybe Text)]
pids of
		[] -> HsDevError -> ClientM m [ModuleId]
forall (m :: * -> *) a. MonadThrow m => HsDevError -> m a
hsdevError (HsDevError -> ClientM m [ModuleId])
-> HsDevError -> ClientM m [ModuleId]
forall a b. (a -> b) -> a -> b
$ String -> HsDevError
OtherError (String -> HsDevError) -> String -> HsDevError
forall a b. (a -> b) -> a -> b
$ Format
"module at {} not found" Format -> Text -> String
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ Text
fpath
		[Only Maybe Text
proj] -> Query -> (Maybe Text, Text) -> ClientM m [ModuleId]
forall q r (m :: * -> *).
(ToRow q, FromRow r, SessionMonad m) =>
Query -> q -> m [r]
query @_ @ModuleId (Select Text -> Query
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 [
			Select Text
qModuleId,
			[Text] -> Select Text
forall a. [a] -> Select a
from_ [Text
"projects_modules_scope as msc"],
			[Text] -> Select Text
forall a. [a] -> Select a
where_ [
				Text
"msc.module_id == mu.id",
				Text
"msc.cabal is ?",
				Text
"mu.name like ? escape '\\'"]])
			(Maybe Text
proj, SearchQuery -> Text
likePattern SearchQuery
sq)
		[Only (Maybe Text)]
_ -> String -> ClientM m [ModuleId]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Impossible happened: several projects for one module"
runCommand (ResolveScope SearchQuery
sq Text
fpath) = ClientM m [Scoped SymbolId] -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m [Scoped SymbolId] -> ClientM m Value)
-> ClientM m [Scoped SymbolId] -> ClientM m Value
forall a b. (a -> b) -> a -> b
$
	Query -> (String, Text) -> ClientM m [Scoped SymbolId]
forall q r (m :: * -> *).
(ToRow q, FromRow r, SessionMonad m) =>
Query -> q -> m [r]
query @_ @(Scoped SymbolId) (Select Text -> Query
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 [
		Select Text
qSymbolId,
		[Text] -> Select Text
forall a. [a] -> Select a
select_ [Text
"sc.qualifier"],
		[Text] -> Select Text
forall a. [a] -> Select a
from_ [Text
"scopes as sc", Text
"modules as srcm"],
		[Text] -> Select Text
forall a. [a] -> Select a
where_ [
			Text
"srcm.id == sc.module_id",
			Text
"sc.symbol_id == s.id",
			Text
"srcm.file == ?",
			Text
"s.name like ? escape '\\'"]])
		(Text
fpath Text -> Getting String Text String -> String
forall s a. s -> Getting a s a -> a
^. Getting String Text String
Lens' Text String
path, SearchQuery -> Text
likePattern SearchQuery
sq)
runCommand (FindUsages Int
l Int
c Text
fpath) = ClientM m [SymbolUsage] -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m [SymbolUsage] -> ClientM m Value)
-> ClientM m [SymbolUsage] -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ do
	[SymbolUsage]
us <- do
		[Only (Maybe Int)]
sids <- Query -> (Int, Int, Text) -> ClientM m [Only (Maybe Int)]
forall q r (m :: * -> *).
(ToRow q, FromRow r, SessionMonad m) =>
Query -> q -> m [r]
query @_ @(Only (Maybe Int)) (Select Text -> Query
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] -> Select Text
forall a. [a] -> Select a
select_ [Text
"n.symbol_id"],
			[Text] -> Select Text
forall a. [a] -> Select a
from_ [Text
"names as n", Text
"modules as srcm"],
			[Text] -> Select Text
forall a. [a] -> Select a
where_ [
				Text
"n.module_id == srcm.id",
				Text
"(?, ?) between (n.line, n.column) and (n.line_to, n.column_to)",
				Text
"srcm.file = ?"]])
			(Int
l, Int
c, Text
fpath)
		Bool -> ClientM m () -> ClientM m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Only (Maybe Int)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Only (Maybe Int)]
sids Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (ClientM m () -> ClientM m ()) -> ClientM m () -> ClientM m ()
forall a b. (a -> b) -> a -> b
$ Level -> Text -> ClientM m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Warning (Text -> ClientM m ()) -> Text -> ClientM m ()
forall a b. (a -> b) -> a -> b
$ Format
"multiple symbols found at location {0}:{1}:{2}" Format -> Text -> Format
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ Text
fpath Format -> Int -> Format
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ Int
l Format -> Int -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ Int
c
		let
			msid :: Maybe Int
msid = Maybe (Maybe Int) -> Maybe Int
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe Int) -> Maybe Int) -> Maybe (Maybe Int) -> Maybe Int
forall a b. (a -> b) -> a -> b
$ (Only (Maybe Int) -> Maybe Int)
-> Maybe (Only (Maybe Int)) -> Maybe (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Only (Maybe Int) -> Maybe Int
forall a. Only a -> a
fromOnly (Maybe (Only (Maybe Int)) -> Maybe (Maybe Int))
-> Maybe (Only (Maybe Int)) -> Maybe (Maybe Int)
forall a b. (a -> b) -> a -> b
$ [Only (Maybe Int)] -> Maybe (Only (Maybe Int))
forall a. [a] -> Maybe a
listToMaybe [Only (Maybe Int)]
sids
		Query -> Only (Maybe Int) -> ClientM m [SymbolUsage]
forall q r (m :: * -> *).
(ToRow q, FromRow r, SessionMonad m) =>
Query -> q -> m [r]
query @_ @SymbolUsage (Select Text -> Query
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 [
			Select Text
qSymbol,
			[Text] -> Select Text
forall a. [a] -> Select a
select_ [Text
"n.qualifier"],
			Select Text
qModuleId,
			[Text] -> Select Text
forall a. [a] -> Select a
select_ [Text
"n.line", Text
"n.column", Text
"n.line_to", Text
"n.column_to"],
			[Text] -> Select Text
forall a. [a] -> Select a
from_ [Text
"names as n"],
			[Text] -> Select Text
forall a. [a] -> Select a
where_ [
				Text
"n.symbol_id == ?",
				Text
"s.id == n.symbol_id",
				Text
"mu.id == n.module_id"]])
			(Maybe Int -> Only (Maybe Int)
forall a. a -> Only a
Only Maybe Int
msid)
	[SymbolUsage]
locals <- do
		[ModuleId
 :. (Only Text :. (Position :. (Only (Maybe Text) :. Region)))]
defs <- Query
-> (Int, Int, String)
-> ClientM
     m
     [ModuleId
      :. (Only Text :. (Position :. (Only (Maybe Text) :. Region)))]
forall q r (m :: * -> *).
(ToRow q, FromRow r, SessionMonad m) =>
Query -> q -> m [r]
query @_ @(ModuleId :. Only Text :. Position :. Only (Maybe Text) :. Region) (Select Text -> Query
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 [
			Select Text
qModuleId,
			[Text] -> Select Text
forall a. [a] -> Select a
select_ [Text
"n.name", Text
"n.def_line", Text
"n.def_column", Text
"n.inferred_type", Text
"n.line", Text
"n.column", Text
"n.line_to", Text
"n.column_to"],
			[Text] -> Select Text
forall a. [a] -> Select a
from_ [Text
"names as n", Text
"names as defn"],
			[Text] -> Select Text
forall a. [a] -> Select a
where_ [
				Text
"n.module_id = mu.id",
				Text
"n.def_line = defn.def_line",
				Text
"n.def_column = defn.def_column",
				Text
"defn.module_id = mu.id",
				Text
"(?, ?) between (defn.line, defn.column) and (defn.line_to, defn.column_to)",
				Text
"mu.file = ?"]])
			(Int
l, Int
c, Text
fpath Text -> Getting String Text String -> String
forall s a. s -> Getting a s a -> a
^. Getting String Text String
Lens' Text String
path)
		[SymbolUsage] -> ClientM m [SymbolUsage]
forall (m :: * -> *) a. Monad m => a -> m a
return ([SymbolUsage] -> ClientM m [SymbolUsage])
-> [SymbolUsage] -> ClientM m [SymbolUsage]
forall a b. (a -> b) -> a -> b
$ do
			(ModuleId
mid :. Only Text
nm :. Position
defPos :. Only Maybe Text
ftype :. Region
useRgn) <- [ModuleId
 :. (Only Text :. (Position :. (Only (Maybe Text) :. Region)))]
defs
			let
				sym :: Symbol
sym = Symbol :: SymbolId -> Maybe Text -> Maybe Position -> SymbolInfo -> Symbol
Symbol {
					_symbolId :: SymbolId
_symbolId = Text -> ModuleId -> SymbolId
SymbolId Text
nm ModuleId
mid,
					_symbolDocs :: Maybe Text
_symbolDocs = Maybe Text
forall a. Maybe a
Nothing,
					_symbolPosition :: Maybe Position
_symbolPosition = Position -> Maybe Position
forall a. a -> Maybe a
Just Position
defPos,
					_symbolInfo :: SymbolInfo
_symbolInfo = Maybe Text -> SymbolInfo
Function Maybe Text
ftype }
			SymbolUsage -> [SymbolUsage]
forall (m :: * -> *) a. Monad m => a -> m a
return (SymbolUsage -> [SymbolUsage]) -> SymbolUsage -> [SymbolUsage]
forall a b. (a -> b) -> a -> b
$ Symbol -> Maybe Text -> ModuleId -> Region -> SymbolUsage
SymbolUsage Symbol
sym Maybe Text
forall a. Maybe a
Nothing ModuleId
mid Region
useRgn
	[SymbolUsage] -> ClientM m [SymbolUsage]
forall (m :: * -> *) a. Monad m => a -> m a
return ([SymbolUsage] -> ClientM m [SymbolUsage])
-> [SymbolUsage] -> ClientM m [SymbolUsage]
forall a b. (a -> b) -> a -> b
$ [SymbolUsage]
us [SymbolUsage] -> [SymbolUsage] -> [SymbolUsage]
forall a. [a] -> [a] -> [a]
++ [SymbolUsage]
locals
runCommand (Complete Text
input Bool
True Text
fpath) = ClientM m [Symbol] -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m [Symbol] -> ClientM m Value)
-> ClientM m [Symbol] -> ClientM m Value
forall a b. (a -> b) -> a -> b
$
	Query -> (String, Text) -> ClientM m [Symbol]
forall q r (m :: * -> *).
(ToRow q, FromRow r, SessionMonad m) =>
Query -> q -> m [r]
query @_ @Symbol (Select Text -> Query
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 [
		Select Text
qSymbol,
		[Text] -> Select Text
forall a. [a] -> Select a
from_ [Text
"modules as srcm", Text
"exports as e"],
		[Text] -> Select Text
forall a. [a] -> Select a
where_ [
			Text
"e.module_id in (select srcm.id union select module_id from projects_modules_scope where (((cabal is null) and (srcm.cabal is null)) or (cabal == srcm.cabal)))",
			Text
"s.id == e.symbol_id",
			Text
"msrc.file == ?",
			Text
"s.name like ? escape '\\'"]])
		(Text
fpath Text -> Getting String Text String -> String
forall s a. s -> Getting a s a -> a
^. Getting String Text String
Lens' Text String
path, SearchQuery -> Text
likePattern (Text -> SearchType -> SearchQuery
SearchQuery Text
input SearchType
SearchPrefix))
runCommand (Complete Text
input Bool
False Text
fpath) = ClientM m [Scoped Symbol] -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m [Scoped Symbol] -> ClientM m Value)
-> ClientM m [Scoped Symbol] -> ClientM m Value
forall a b. (a -> b) -> a -> b
$
	Query -> (String, Text) -> ClientM m [Scoped Symbol]
forall q r (m :: * -> *).
(ToRow q, FromRow r, SessionMonad m) =>
Query -> q -> m [r]
query @_ @(Scoped Symbol) (Select Text -> Query
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 [
		Select Text
qSymbol,
		[Text] -> Select Text
forall a. [a] -> Select a
select_ [Text
"c.qualifier"],
		[Text] -> Select Text
forall a. [a] -> Select a
from_ [Text
"completions as c", Text
"modules as srcm"],
		[Text] -> Select Text
forall a. [a] -> Select a
where_ [
			Text
"c.module_id == srcm.id",
			Text
"c.symbol_id == s.id",
			Text
"srcm.file == ?",
			Text
"c.completion like ? escape '\\'"]])
		(Text
fpath Text -> Getting String Text String -> String
forall s a. s -> Getting a s a -> a
^. Getting String Text String
Lens' Text String
path, SearchQuery -> Text
likePattern (Text -> SearchType -> SearchQuery
SearchQuery Text
input SearchType
SearchPrefix))
runCommand (Hayoo String
hq Int
p Int
ps) = do
	Manager
m <- (Session -> Manager) -> ClientM m Manager
forall (m :: * -> *) a. SessionMonad m => (Session -> a) -> m a
askSession Session -> Manager
sessionHTTPManager
	ClientM m [Symbol] -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m [Symbol] -> ClientM m Value)
-> ClientM m [Symbol] -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ ([[Symbol]] -> [Symbol])
-> ClientM m [[Symbol]] -> ClientM m [Symbol]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[Symbol]] -> [Symbol]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (ClientM m [[Symbol]] -> ClientM m [Symbol])
-> ClientM m [[Symbol]] -> ClientM m [Symbol]
forall a b. (a -> b) -> a -> b
$ [Int] -> (Int -> ClientM m [Symbol]) -> ClientM m [[Symbol]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
p .. Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int
forall a. Enum a => a -> a
pred Int
ps] ((Int -> ClientM m [Symbol]) -> ClientM m [[Symbol]])
-> (Int -> ClientM m [Symbol]) -> ClientM m [[Symbol]]
forall a b. (a -> b) -> a -> b
$ \Int
i -> (HayooResult -> [Symbol])
-> ClientM m HayooResult -> ClientM m [Symbol]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
		((HayooSymbol -> Maybe Symbol) -> [HayooSymbol] -> [Symbol]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe HayooSymbol -> Maybe Symbol
Hayoo.hayooAsSymbol ([HayooSymbol] -> [Symbol])
-> (HayooResult -> [HayooSymbol]) -> HayooResult -> [Symbol]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HayooResult -> [HayooSymbol]
Hayoo.resultResult) (ClientM m HayooResult -> ClientM m [Symbol])
-> ClientM m HayooResult -> ClientM m [Symbol]
forall a b. (a -> b) -> a -> b
$
		IO HayooResult -> ClientM m HayooResult
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HayooResult -> ClientM m HayooResult)
-> IO HayooResult -> ClientM m HayooResult
forall a b. (a -> b) -> a -> b
$ ExceptT String IO HayooResult -> IO HayooResult
forall (m :: * -> *) a. MonadThrow m => ExceptT String m a -> m a
hsdevLift (ExceptT String IO HayooResult -> IO HayooResult)
-> ExceptT String IO HayooResult -> IO HayooResult
forall a b. (a -> b) -> a -> b
$ Manager -> String -> Maybe Int -> ExceptT String IO HayooResult
Hayoo.hayoo Manager
m String
hq (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
i)
runCommand (CabalList [Text]
packages') = ClientM m [CabalPackage] -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m [CabalPackage] -> ClientM m Value)
-> ClientM m [CabalPackage] -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ IO [CabalPackage] -> ClientM m [CabalPackage]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [CabalPackage] -> ClientM m [CabalPackage])
-> IO [CabalPackage] -> ClientM m [CabalPackage]
forall a b. (a -> b) -> a -> b
$ ExceptT String IO [CabalPackage] -> IO [CabalPackage]
forall (m :: * -> *) a. MonadThrow m => ExceptT String m a -> m a
hsdevLift (ExceptT String IO [CabalPackage] -> IO [CabalPackage])
-> ExceptT String IO [CabalPackage] -> IO [CabalPackage]
forall a b. (a -> b) -> a -> b
$ [String] -> ExceptT String IO [CabalPackage]
Cabal.cabalList ([String] -> ExceptT String IO [CabalPackage])
-> [String] -> ExceptT String IO [CabalPackage]
forall a b. (a -> b) -> a -> b
$ (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
unpack [Text]
packages'
runCommand (UnresolvedSymbols [Text]
fs) = ClientM m [Value] -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m [Value] -> ClientM m Value)
-> ClientM m [Value] -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ ([[Value]] -> [Value]) -> ClientM m [[Value]] -> ClientM m [Value]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[Value]] -> [Value]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (ClientM m [[Value]] -> ClientM m [Value])
-> ClientM m [[Value]] -> ClientM m [Value]
forall a b. (a -> b) -> a -> b
$ [Text] -> (Text -> ClientM m [Value]) -> ClientM m [[Value]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Text]
fs ((Text -> ClientM m [Value]) -> ClientM m [[Value]])
-> (Text -> ClientM m [Value]) -> ClientM m [[Value]]
forall a b. (a -> b) -> a -> b
$ \Text
f -> do
	[(Maybe String, String, Int, Int)]
rs <- Query
-> Only String -> ClientM m [(Maybe String, String, Int, Int)]
forall q r (m :: * -> *).
(ToRow q, FromRow r, SessionMonad m) =>
Query -> q -> m [r]
query @_ @(Maybe String, String, Int, Int) Query
"select n.qualifier, n.name, n.line, n.column from modules as m, names as n where (m.id == n.module_id) and (m.file == ?) and (n.resolve_error is not null);"
		(String -> Only String
forall a. a -> Only a
Only (String -> Only String) -> String -> Only String
forall a b. (a -> b) -> a -> b
$ Text
f Text -> Getting String Text String -> String
forall s a. s -> Getting a s a -> a
^. Getting String Text String
Lens' Text String
path)
	[Value] -> ClientM m [Value]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Value] -> ClientM m [Value]) -> [Value] -> ClientM m [Value]
forall a b. (a -> b) -> a -> b
$ ((Maybe String, String, Int, Int) -> Value)
-> [(Maybe String, String, Int, Int)] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map (\(Maybe String
m, String
nm, Int
line, Int
column) -> [Pair] -> Value
object [
		Text
"qualifier" Text -> Maybe String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Maybe String
m,
		Text
"name" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= String
nm,
		Text
"line" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Int
line,
		Text
"column" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Int
column]) [(Maybe String, String, Int, Int)]
rs
runCommand (Lint [FileSource]
fs [String]
lints) = ClientM m [Note OutputMessage] -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m [Note OutputMessage] -> ClientM m Value)
-> ClientM m [Note OutputMessage] -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ ([[Note OutputMessage]] -> [Note OutputMessage])
-> ClientM m [[Note OutputMessage]]
-> ClientM 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 (ClientM m [[Note OutputMessage]]
 -> ClientM m [Note OutputMessage])
-> ClientM m [[Note OutputMessage]]
-> ClientM m [Note OutputMessage]
forall a b. (a -> b) -> a -> b
$ [FileSource]
-> (FileSource -> ClientM m [Note OutputMessage])
-> ClientM m [[Note OutputMessage]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [FileSource]
fs ((FileSource -> ClientM m [Note OutputMessage])
 -> ClientM m [[Note OutputMessage]])
-> (FileSource -> ClientM m [Note OutputMessage])
-> ClientM m [[Note OutputMessage]]
forall a b. (a -> b) -> a -> b
$ \FileSource
fsrc -> do
	FileSource Text
f Maybe Text
c <- FileSource -> ClientM m FileSource
forall (m :: * -> *). CommandMonad m => FileSource -> m FileSource
getUpdateFileContents FileSource
fsrc
	IO [Note OutputMessage] -> ClientM m [Note OutputMessage]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Note OutputMessage] -> ClientM m [Note OutputMessage])
-> IO [Note OutputMessage] -> ClientM m [Note OutputMessage]
forall a b. (a -> b) -> a -> b
$ ExceptT String IO [Note OutputMessage] -> IO [Note OutputMessage]
forall (m :: * -> *) a. MonadThrow m => ExceptT String m a -> m a
hsdevLift (ExceptT String IO [Note OutputMessage] -> IO [Note OutputMessage])
-> ExceptT String IO [Note OutputMessage]
-> IO [Note OutputMessage]
forall a b. (a -> b) -> a -> b
$ [String]
-> String -> Maybe Text -> ExceptT String IO [Note OutputMessage]
HLint.hlint [String]
lints (Getting String Text String -> Text -> String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting String Text String
Lens' Text String
path Text
f) Maybe Text
c
runCommand (Check [FileSource]
fs [String]
ghcs' Bool
clear) = ClientM m [Note OutputMessage] -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m [Note OutputMessage] -> ClientM m Value)
-> ClientM m [Note OutputMessage] -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ Text
-> ClientM m [Note OutputMessage] -> ClientM m [Note OutputMessage]
forall (m :: * -> *) a.
(MonadLog m, HasCallStack) =>
Text -> m a -> m a
Log.scope Text
"check" (ClientM m [Note OutputMessage] -> ClientM m [Note OutputMessage])
-> ClientM m [Note OutputMessage] -> ClientM m [Note OutputMessage]
forall a b. (a -> b) -> a -> b
$
	([[Note OutputMessage]] -> [Note OutputMessage])
-> ClientM m [[Note OutputMessage]]
-> ClientM 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 (ClientM m [[Note OutputMessage]]
 -> ClientM m [Note OutputMessage])
-> ClientM m [[Note OutputMessage]]
-> ClientM m [Note OutputMessage]
forall a b. (a -> b) -> a -> b
$ (FileSource -> ClientM m [Note OutputMessage])
-> [FileSource] -> ClientM m [[Note OutputMessage]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([String] -> Bool -> FileSource -> ClientM m [Note OutputMessage]
forall (m :: * -> *).
CommandMonad m =>
[String] -> Bool -> FileSource -> m [Note OutputMessage]
runCheck [String]
ghcs' Bool
clear) [FileSource]
fs
runCommand (CheckLint [FileSource]
fs [String]
ghcs' [String]
lints Bool
clear) = ClientM m [Note OutputMessage] -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m [Note OutputMessage] -> ClientM m Value)
-> ClientM m [Note OutputMessage] -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ do
	[FileSource]
fs' <- (FileSource -> ClientM m FileSource)
-> [FileSource] -> ClientM m [FileSource]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FileSource -> ClientM m FileSource
forall (m :: * -> *). CommandMonad m => FileSource -> m FileSource
getUpdateFileContents [FileSource]
fs
	[Note OutputMessage]
checkMsgs <- ([[Note OutputMessage]] -> [Note OutputMessage])
-> ClientM m [[Note OutputMessage]]
-> ClientM 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 (ClientM m [[Note OutputMessage]]
 -> ClientM m [Note OutputMessage])
-> ClientM m [[Note OutputMessage]]
-> ClientM m [Note OutputMessage]
forall a b. (a -> b) -> a -> b
$ (FileSource -> ClientM m [Note OutputMessage])
-> [FileSource] -> ClientM m [[Note OutputMessage]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([String] -> Bool -> FileSource -> ClientM m [Note OutputMessage]
forall (m :: * -> *).
CommandMonad m =>
[String] -> Bool -> FileSource -> m [Note OutputMessage]
runCheck [String]
ghcs' Bool
clear) [FileSource]
fs'
	[Note OutputMessage]
lintMsgs <- IO [Note OutputMessage] -> ClientM m [Note OutputMessage]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Note OutputMessage] -> ClientM m [Note OutputMessage])
-> IO [Note OutputMessage] -> ClientM m [Note OutputMessage]
forall a b. (a -> b) -> a -> b
$ ExceptT String IO [Note OutputMessage] -> IO [Note OutputMessage]
forall (m :: * -> *) a. MonadThrow m => ExceptT String m a -> m a
hsdevLift (ExceptT String IO [Note OutputMessage] -> IO [Note OutputMessage])
-> ExceptT String IO [Note OutputMessage]
-> IO [Note OutputMessage]
forall a b. (a -> b) -> a -> b
$ ([[Note OutputMessage]] -> [Note OutputMessage])
-> ExceptT String IO [[Note OutputMessage]]
-> ExceptT String IO [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 (ExceptT String IO [[Note OutputMessage]]
 -> ExceptT String IO [Note OutputMessage])
-> ExceptT String IO [[Note OutputMessage]]
-> ExceptT String IO [Note OutputMessage]
forall a b. (a -> b) -> a -> b
$ (FileSource -> ExceptT String IO [Note OutputMessage])
-> [FileSource] -> ExceptT String IO [[Note OutputMessage]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(FileSource Text
f Maybe Text
c) -> [String]
-> String -> Maybe Text -> ExceptT String IO [Note OutputMessage]
HLint.hlint [String]
lints (Getting String Text String -> Text -> String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting String Text String
Lens' Text String
path Text
f) Maybe Text
c) [FileSource]
fs'
	[Note OutputMessage] -> ClientM m [Note OutputMessage]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Note OutputMessage] -> ClientM m [Note OutputMessage])
-> [Note OutputMessage] -> ClientM m [Note OutputMessage]
forall a b. (a -> b) -> a -> b
$ [Note OutputMessage]
checkMsgs [Note OutputMessage]
-> [Note OutputMessage] -> [Note OutputMessage]
forall a. [a] -> [a] -> [a]
++ [Note OutputMessage]
lintMsgs
runCommand (Types [FileSource]
fs [String]
ghcs' Bool
clear) = ClientM m [Note TypedExpr] -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m [Note TypedExpr] -> ClientM m Value)
-> ClientM m [Note TypedExpr] -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ do
	([[Note TypedExpr]] -> [Note TypedExpr])
-> ClientM m [[Note TypedExpr]] -> ClientM m [Note TypedExpr]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[Note TypedExpr]] -> [Note TypedExpr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (ClientM m [[Note TypedExpr]] -> ClientM m [Note TypedExpr])
-> ClientM m [[Note TypedExpr]] -> ClientM m [Note TypedExpr]
forall a b. (a -> b) -> a -> b
$ [FileSource]
-> (FileSource -> ClientM m [Note TypedExpr])
-> ClientM m [[Note TypedExpr]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [FileSource]
fs ((FileSource -> ClientM m [Note TypedExpr])
 -> ClientM m [[Note TypedExpr]])
-> (FileSource -> ClientM m [Note TypedExpr])
-> ClientM m [[Note TypedExpr]]
forall a b. (a -> b) -> a -> b
$ \fsrc :: FileSource
fsrc@(FileSource Text
file Maybe Text
msrc) -> do
		Maybe [Note TypedExpr]
mcached' <- Text -> Maybe Text -> ClientM m (Maybe [Note TypedExpr])
forall (m :: * -> *).
ServerMonadBase m =>
Text -> Maybe Text -> ClientM m (Maybe [Note TypedExpr])
getCached Text
file Maybe Text
msrc
		FileSource Text
_ Maybe Text
msrc' <- FileSource -> ClientM m FileSource
forall (m :: * -> *). CommandMonad m => FileSource -> m FileSource
getUpdateFileContents FileSource
fsrc
		ClientM m [Note TypedExpr]
-> ([Note TypedExpr] -> ClientM m [Note TypedExpr])
-> Maybe [Note TypedExpr]
-> ClientM m [Note TypedExpr]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Maybe Text -> ClientM m [Note TypedExpr]
forall (m :: * -> *).
(MonadPlus m, MonadBaseControl IO m, MonadMask m, MonadFail m,
 MonadIO m) =>
Text -> Maybe Text -> ClientM m [Note TypedExpr]
updateTypes Text
file Maybe Text
msrc') [Note TypedExpr] -> ClientM m [Note TypedExpr]
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Note TypedExpr]
mcached'
	where
		getCached :: ServerMonadBase m => Path -> Maybe Text -> ClientM m (Maybe [Tools.Note Types.TypedExpr])
		getCached :: Text -> Maybe Text -> ClientM m (Maybe [Note TypedExpr])
getCached Text
_ (Just Text
_) = Maybe [Note TypedExpr] -> ClientM m (Maybe [Note TypedExpr])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Note TypedExpr]
forall a. Maybe a
Nothing
		getCached Text
file' Maybe Text
Nothing = do
			Bool
actual' <- Text -> ClientM m Bool
forall (m :: * -> *). CommandMonad m => Text -> m Bool
sourceUpToDate Text
file'
			[(Bool, Int) :. ModuleId]
mid <- Query -> Only Text -> ClientM m [(Bool, Int) :. ModuleId]
forall q r (m :: * -> *).
(ToRow q, FromRow r, SessionMonad m) =>
Query -> q -> m [r]
query @_ @((Bool, Int) :. ModuleId)
				(Select Text -> Query
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] -> Select Text
forall a. [a] -> Select a
select_ [Text
"json_extract(tags, '$.types') is 1", Text
"mu.id"],
					Select Text
qModuleId,
					[Text] -> Select Text
forall a. [a] -> Select a
where_ [Text
"mu.file = ?"]])
				(Text -> Only Text
forall a. a -> Only a
Only Text
file')
			Bool -> ClientM m () -> ClientM m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([(Bool, Int) :. ModuleId] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Bool, Int) :. ModuleId]
mid Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (ClientM m () -> ClientM m ()) -> ClientM m () -> ClientM m ()
forall a b. (a -> b) -> a -> b
$ Level -> Text -> ClientM m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Warning (Text -> ClientM m ()) -> Text -> ClientM m ()
forall a b. (a -> b) -> a -> b
$ Format
"multiple modules with same file = {}" Format -> Text -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ Text
file'
			Bool -> ClientM m () -> ClientM m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([(Bool, Int) :. ModuleId] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Bool, Int) :. ModuleId]
mid) (ClientM m () -> ClientM m ()) -> ClientM m () -> ClientM m ()
forall a b. (a -> b) -> a -> b
$ HsDevError -> ClientM m ()
forall (m :: * -> *) a. MonadThrow m => HsDevError -> m a
hsdevError (HsDevError -> ClientM m ()) -> HsDevError -> ClientM m ()
forall a b. (a -> b) -> a -> b
$ ModuleLocation -> HsDevError
NotInspected (ModuleLocation -> HsDevError) -> ModuleLocation -> HsDevError
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Project -> ModuleLocation
FileModule Text
file' Maybe Project
forall a. Maybe a
Nothing
			let
				[(Bool
hasTypes', Int
mid') :. ModuleId
modId] = [(Bool, Int) :. ModuleId]
mid
			if Bool
actual' Bool -> Bool -> Bool
&& Bool
hasTypes'
				then do
					[Region :. TypedExpr]
types' <- Query -> Only Int -> ClientM m [Region :. TypedExpr]
forall q r (m :: * -> *).
(ToRow q, FromRow r, SessionMonad m) =>
Query -> q -> m [r]
query @_ @(Region :. Types.TypedExpr) Query
"select line, column, line_to, column_to, expr, type from types where module_id = ?;" (Int -> Only Int
forall a. a -> Only a
Only Int
mid')
					([Note TypedExpr] -> Maybe [Note TypedExpr])
-> ClientM m [Note TypedExpr] -> ClientM m (Maybe [Note TypedExpr])
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Note TypedExpr] -> Maybe [Note TypedExpr]
forall a. a -> Maybe a
Just (ClientM m [Note TypedExpr] -> ClientM m (Maybe [Note TypedExpr]))
-> ClientM m [Note TypedExpr] -> ClientM m (Maybe [Note TypedExpr])
forall a b. (a -> b) -> a -> b
$ [Region :. TypedExpr]
-> ((Region :. TypedExpr) -> ClientM m (Note TypedExpr))
-> ClientM m [Note TypedExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Region :. TypedExpr]
types' (((Region :. TypedExpr) -> ClientM m (Note TypedExpr))
 -> ClientM m [Note TypedExpr])
-> ((Region :. TypedExpr) -> ClientM m (Note TypedExpr))
-> ClientM m [Note TypedExpr]
forall a b. (a -> b) -> a -> b
$ \(Region
rgn :. TypedExpr
texpr) -> Note TypedExpr -> ClientM m (Note TypedExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return Note :: forall a1.
ModuleLocation -> Region -> Maybe Severity -> a1 -> Note a1
Tools.Note {
						_noteSource :: ModuleLocation
Tools._noteSource = ModuleId
modId ModuleId
-> Getting ModuleLocation ModuleId ModuleLocation -> ModuleLocation
forall s a. s -> Getting a s a -> a
^. Getting ModuleLocation ModuleId ModuleLocation
Lens' ModuleId ModuleLocation
moduleLocation,
						_noteRegion :: Region
Tools._noteRegion = Region
rgn,
						_noteLevel :: Maybe Severity
Tools._noteLevel = Maybe Severity
forall a. Maybe a
Nothing,
						_note :: TypedExpr
Tools._note = ASetter TypedExpr TypedExpr (Maybe Text) (Maybe Text)
-> Maybe Text -> TypedExpr -> TypedExpr
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter TypedExpr TypedExpr (Maybe Text) (Maybe Text)
Lens' TypedExpr (Maybe Text)
Types.typedExpr Maybe Text
forall a. Maybe a
Nothing TypedExpr
texpr }
				else Maybe [Note TypedExpr] -> ClientM m (Maybe [Note TypedExpr])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Note TypedExpr]
forall a. Maybe a
Nothing

		updateTypes :: Text -> Maybe Text -> ClientM m [Note TypedExpr]
updateTypes Text
file Maybe Text
msrc = do
			Session
sess <- ClientM m Session
forall (m :: * -> *). SessionMonad m => m Session
getSession
			Module
m <- [String] -> Text -> ClientM m Module
forall (m :: * -> *).
CommandMonad m =>
[String] -> Text -> m Module
setFileSourceSession [String]
ghcs' Text
file
			[Note TypedExpr]
types' <- GhcM [Note TypedExpr] -> ClientM m [Note TypedExpr]
forall (m :: * -> *) a. SessionMonad m => GhcM a -> m a
inSessionGhc (GhcM [Note TypedExpr] -> ClientM m [Note TypedExpr])
-> GhcM [Note TypedExpr] -> ClientM m [Note TypedExpr]
forall a b. (a -> b) -> a -> b
$ do
				Bool
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
clear MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall (m :: * -> *). GhcMonad m => m ()
clearTargets
				Session
-> [ModuleLocation]
-> GhcM [Note TypedExpr]
-> GhcM [Note TypedExpr]
forall a. Session -> [ModuleLocation] -> GhcM a -> GhcM a
Update.cacheGhcWarnings Session
sess [Module
m Module
-> Getting ModuleLocation Module ModuleLocation -> ModuleLocation
forall s a. s -> Getting a s a -> a
^. (ModuleId -> Const ModuleLocation ModuleId)
-> Module -> Const ModuleLocation Module
Lens' Module ModuleId
moduleId ((ModuleId -> Const ModuleLocation ModuleId)
 -> Module -> Const ModuleLocation Module)
-> Getting ModuleLocation ModuleId ModuleLocation
-> Getting ModuleLocation Module ModuleLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting ModuleLocation ModuleId ModuleLocation
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]
Types.fileTypes Module
m Maybe Text
msrc
			UpdateOptions -> [UpdateM IO ()] -> ClientM m ()
forall (m :: * -> *).
ServerMonadBase m =>
UpdateOptions -> [UpdateM IO ()] -> ClientM m ()
updateProcess UpdateOptions
forall a. Default a => a
def [ModuleId -> [Note TypedExpr] -> UpdateM IO ()
forall (m :: * -> *).
UpdateMonad m =>
ModuleId -> [Note TypedExpr] -> m ()
Update.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']
			[Note TypedExpr] -> ClientM m [Note TypedExpr]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Note TypedExpr] -> ClientM m [Note TypedExpr])
-> [Note TypedExpr] -> ClientM m [Note TypedExpr]
forall a b. (a -> b) -> a -> b
$ ASetter [Note TypedExpr] [Note TypedExpr] (Maybe Text) (Maybe Text)
-> Maybe Text -> [Note TypedExpr] -> [Note TypedExpr]
forall s t a b. ASetter s t a b -> b -> s -> t
set ((Note TypedExpr -> Identity (Note TypedExpr))
-> [Note TypedExpr] -> Identity [Note TypedExpr]
forall s t a b. Each s t a b => Traversal s t a b
each ((Note TypedExpr -> Identity (Note TypedExpr))
 -> [Note TypedExpr] -> Identity [Note TypedExpr])
-> ((Maybe Text -> Identity (Maybe Text))
    -> Note TypedExpr -> Identity (Note TypedExpr))
-> ASetter
     [Note TypedExpr] [Note TypedExpr] (Maybe Text) (Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypedExpr -> Identity TypedExpr)
-> Note TypedExpr -> Identity (Note TypedExpr)
forall a1 a2. Lens (Note a1) (Note a2) a1 a2
Tools.note ((TypedExpr -> Identity TypedExpr)
 -> Note TypedExpr -> Identity (Note TypedExpr))
-> ASetter TypedExpr TypedExpr (Maybe Text) (Maybe Text)
-> (Maybe Text -> Identity (Maybe Text))
-> Note TypedExpr
-> Identity (Note TypedExpr)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter TypedExpr TypedExpr (Maybe Text) (Maybe Text)
Lens' TypedExpr (Maybe Text)
Types.typedExpr) Maybe Text
forall a. Maybe a
Nothing [Note TypedExpr]
types'
runCommand (AutoFix [Note OutputMessage]
ns) = ClientM m [Note Refact] -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m [Note Refact] -> ClientM m Value)
-> ClientM m [Note Refact] -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ [Note Refact] -> ClientM m [Note Refact]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Note Refact] -> ClientM m [Note Refact])
-> [Note Refact] -> ClientM m [Note Refact]
forall a b. (a -> b) -> a -> b
$ [Note OutputMessage] -> [Note Refact]
AutoFix.corrections [Note OutputMessage]
ns
runCommand (Refactor [Note Refact]
ns [Note Refact]
rest Bool
isPure) = ClientM m [Note Refact] -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m [Note Refact] -> ClientM m Value)
-> ClientM m [Note Refact] -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ do
	[Text]
files <- ([Text] -> [Text]) -> ClientM m [Text] -> ClientM m [Text]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ([Text] -> [Text]
forall a. Ord a => [a] -> [a]
ordNub ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
forall a. Ord a => [a] -> [a]
sort) (ClientM m [Text] -> ClientM m [Text])
-> ClientM m [Text] -> ClientM m [Text]
forall a b. (a -> b) -> a -> b
$ (Text -> ClientM m Text) -> [Text] -> ClientM m [Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Text -> ClientM m Text
forall (m :: * -> *) a. (CommandMonad m, Paths a) => a -> m a
findPath ([Text] -> ClientM m [Text]) -> [Text] -> ClientM m [Text]
forall a b. (a -> b) -> a -> b
$ (Note Refact -> Maybe Text) -> [Note Refact] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Getting (First Text) (Note Refact) Text
-> Note Refact -> Maybe Text
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (Getting (First Text) (Note Refact) Text
 -> Note Refact -> Maybe Text)
-> Getting (First Text) (Note Refact) Text
-> Note Refact
-> Maybe Text
forall a b. (a -> b) -> a -> b
$ (ModuleLocation -> Const (First Text) ModuleLocation)
-> Note Refact -> Const (First Text) (Note Refact)
forall a1. Lens' (Note a1) ModuleLocation
Tools.noteSource ((ModuleLocation -> Const (First Text) ModuleLocation)
 -> Note Refact -> Const (First Text) (Note Refact))
-> ((Text -> Const (First Text) Text)
    -> ModuleLocation -> Const (First Text) ModuleLocation)
-> Getting (First Text) (Note Refact) Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const (First Text) Text)
-> ModuleLocation -> Const (First Text) ModuleLocation
Traversal' ModuleLocation Text
moduleFile) [Note Refact]
ns
	let
		runFix :: Text -> m [Note Refact]
runFix Text
file = do
			Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isPure (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
				IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO Text
readFileUtf8 (Getting String Text String -> Text -> String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting String Text String
Lens' Text String
path Text
file) IO Text -> (Text -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Text -> IO ()
writeFileUtf8 (Getting String Text String -> Text -> String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting String Text String
Lens' Text String
path Text
file) (Text -> IO ()) -> (Text -> Text) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Refact] -> Text -> Text
AutoFix.refact [Refact]
fixRefacts'
			[Note Refact] -> m [Note Refact]
forall (m :: * -> *) a. Monad m => a -> m a
return [Note Refact]
newCorrs'
			where
				findCorrs :: Path -> [Tools.Note AutoFix.Refact] -> [Tools.Note AutoFix.Refact]
				findCorrs :: Text -> [Note Refact] -> [Note Refact]
findCorrs Text
f = (Note Refact -> Bool) -> [Note Refact] -> [Note Refact]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
f) (Maybe Text -> Bool)
-> (Note Refact -> Maybe Text) -> Note Refact -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First Text) (Note Refact) Text
-> Note Refact -> Maybe Text
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview ((ModuleLocation -> Const (First Text) ModuleLocation)
-> Note Refact -> Const (First Text) (Note Refact)
forall a1. Lens' (Note a1) ModuleLocation
Tools.noteSource ((ModuleLocation -> Const (First Text) ModuleLocation)
 -> Note Refact -> Const (First Text) (Note Refact))
-> ((Text -> Const (First Text) Text)
    -> ModuleLocation -> Const (First Text) ModuleLocation)
-> Getting (First Text) (Note Refact) Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const (First Text) Text)
-> ModuleLocation -> Const (First Text) ModuleLocation
Traversal' ModuleLocation Text
moduleFile))
				fixCorrs' :: [Note Refact]
fixCorrs' = Text -> [Note Refact] -> [Note Refact]
findCorrs Text
file [Note Refact]
ns
				upCorrs' :: [Note Refact]
upCorrs' = Text -> [Note Refact] -> [Note Refact]
findCorrs Text
file [Note Refact]
rest
				fixRefacts' :: [Refact]
fixRefacts' = [Note Refact]
fixCorrs' [Note Refact]
-> Getting (Endo [Refact]) [Note Refact] Refact -> [Refact]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. (Note Refact -> Const (Endo [Refact]) (Note Refact))
-> [Note Refact] -> Const (Endo [Refact]) [Note Refact]
forall s t a b. Each s t a b => Traversal s t a b
each ((Note Refact -> Const (Endo [Refact]) (Note Refact))
 -> [Note Refact] -> Const (Endo [Refact]) [Note Refact])
-> ((Refact -> Const (Endo [Refact]) Refact)
    -> Note Refact -> Const (Endo [Refact]) (Note Refact))
-> Getting (Endo [Refact]) [Note Refact] Refact
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Refact -> Const (Endo [Refact]) Refact)
-> Note Refact -> Const (Endo [Refact]) (Note Refact)
forall a1 a2. Lens (Note a1) (Note a2) a1 a2
Tools.note
				newCorrs' :: [Note Refact]
newCorrs' = [Refact] -> [Note Refact] -> [Note Refact]
forall a. Regioned a => [Refact] -> [a] -> [a]
AutoFix.update [Refact]
fixRefacts' [Note Refact]
upCorrs'
	([[Note Refact]] -> [Note Refact])
-> ClientM m [[Note Refact]] -> ClientM m [Note Refact]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[Note Refact]] -> [Note Refact]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (ClientM m [[Note Refact]] -> ClientM m [Note Refact])
-> ClientM m [[Note Refact]] -> ClientM m [Note Refact]
forall a b. (a -> b) -> a -> b
$ (Text -> ClientM m [Note Refact])
-> [Text] -> ClientM m [[Note Refact]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Text -> ClientM m [Note Refact]
forall (m :: * -> *). MonadIO m => Text -> m [Note Refact]
runFix [Text]
files
runCommand (Rename Text
nm Text
newName Maybe (Int, Int)
mloc Text
fpath) = ClientM m [Note Refact] -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m [Note Refact] -> ClientM m Value)
-> ClientM m [Note Refact] -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ do
	Module
m <- Text -> ClientM m Module
forall (m :: * -> *). CommandMonad m => Text -> m Module
refineSourceModule Text
fpath
	let
		mname :: Text
mname = Module
m Module -> Getting Text Module Text -> Text
forall s a. s -> Getting a s a -> a
^. (ModuleId -> Const Text ModuleId) -> Module -> Const Text Module
Lens' Module ModuleId
moduleId ((ModuleId -> Const Text ModuleId) -> Module -> Const Text Module)
-> ((Text -> Const Text Text) -> ModuleId -> Const Text ModuleId)
-> Getting Text Module Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const Text Text) -> ModuleId -> Const Text ModuleId
Lens' ModuleId Text
moduleName
		makeNote :: ModuleLocation -> Region -> Note Refact
makeNote ModuleLocation
loc Region
r = Note :: forall a1.
ModuleLocation -> Region -> Maybe Severity -> a1 -> Note a1
Tools.Note {
			_noteSource :: ModuleLocation
Tools._noteSource = ModuleLocation
loc,
			_noteRegion :: Region
Tools._noteRegion = Region
r,
			_noteLevel :: Maybe Severity
Tools._noteLevel = Maybe Severity
forall a. Maybe a
Nothing,
			_note :: Refact
Tools._note = Text -> Replace Text -> Refact
AutoFix.Refact Text
"rename" (Region -> Text -> Replace Text
forall (e :: * -> *) s. EditAction e s => Region -> s -> e s
AutoFix.replace (Region -> Region
AutoFix.fromRegion Region
r) Text
newName) }

	[ClientM m [Note Refact]] -> ClientM m [Note Refact]
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [
		do
			[Region]
topRegions <- Query -> (Text, Text, Maybe Int, Maybe Int) -> ClientM m [Region]
forall q r (m :: * -> *).
(ToRow q, FromRow r, SessionMonad m) =>
Query -> q -> m [r]
query @_ @Region Query
"select n.line, n.column, n.line_to, n.column_to from names as n, modules as m where m.id == n.module_id and m.name == ? and n.name == ? and ((n.def_line is not null and n.def_column is not null) or (n.def_line == ? and n.def_column == ?)) and n.symbol_id is not null;" (
				Text
mname,
				Text
nm,
				((Int, Int) -> Int) -> Maybe (Int, Int) -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, Int) -> Int
forall a b. (a, b) -> a
fst Maybe (Int, Int)
mloc,
				((Int, Int) -> Int) -> Maybe (Int, Int) -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, Int) -> Int
forall a b. (a, b) -> b
snd Maybe (Int, Int)
mloc)
			Bool -> ClientM m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Region] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Region]
topRegions)
			let
				defRenames :: [Note Refact]
defRenames = (Region -> Note Refact) -> [Region] -> [Note Refact]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleLocation -> Region -> Note Refact
makeNote (Module
m Module
-> Getting ModuleLocation Module ModuleLocation -> ModuleLocation
forall s a. s -> Getting a s a -> a
^. (ModuleId -> Const ModuleLocation ModuleId)
-> Module -> Const ModuleLocation Module
Lens' Module ModuleId
moduleId ((ModuleId -> Const ModuleLocation ModuleId)
 -> Module -> Const ModuleLocation Module)
-> Getting ModuleLocation ModuleId ModuleLocation
-> Getting ModuleLocation Module ModuleLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting ModuleLocation ModuleId ModuleLocation
Lens' ModuleId ModuleLocation
moduleLocation)) [Region]
topRegions
			[Note Refact]
usageRenames <- do
				[Only Text :. Region]
usageRegions <- Query -> (Text, Text) -> ClientM m [Only Text :. Region]
forall q r (m :: * -> *).
(ToRow q, FromRow r, SessionMonad m) =>
Query -> q -> m [r]
query @_ @(Only Path :. Region) Query
"select m.file, n.line, n.column, n.line_to, n.column_to from names as n, modules as m where n.module_id == m.id and m.file is not null and n.resolved_module == ? and n.resolved_name == ?;" (
					Text
mname,
					Text
nm)
				[Note Refact] -> ClientM m [Note Refact]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Note Refact] -> ClientM m [Note Refact])
-> [Note Refact] -> ClientM m [Note Refact]
forall a b. (a -> b) -> a -> b
$ ((Only Text :. Region) -> Note Refact)
-> [Only Text :. Region] -> [Note Refact]
forall a b. (a -> b) -> [a] -> [b]
map (\(Only Text
p :. Region
r) -> ModuleLocation -> Region -> Note Refact
makeNote (Text -> Maybe Project -> ModuleLocation
FileModule Text
p Maybe Project
forall a. Maybe a
Nothing) Region
r) [Only Text :. Region]
usageRegions
			[Note Refact] -> ClientM m [Note Refact]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Note Refact] -> ClientM m [Note Refact])
-> [Note Refact] -> ClientM m [Note Refact]
forall a b. (a -> b) -> a -> b
$ [Note Refact] -> [Note Refact]
forall a. Ord a => [a] -> [a]
ordNub ([Note Refact]
defRenames [Note Refact] -> [Note Refact] -> [Note Refact]
forall a. [a] -> [a] -> [a]
++ [Note Refact]
usageRenames),
		do
			[Region]
localRegions <- Query -> (Text, Text, Maybe Int, Maybe Int) -> ClientM m [Region]
forall q r (m :: * -> *).
(ToRow q, FromRow r, SessionMonad m) =>
Query -> q -> m [r]
query @_ @Region Query
"select n.line, n.column, n.line_to, n.column_to from names as n, modules as m where m.id == n.module_id and m.name == ? and n.name == ? and n.def_line == ? and n.def_column == ? and n.symbol_id is null;" (
				Text
mname,
				Text
nm,
				((Int, Int) -> Int) -> Maybe (Int, Int) -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, Int) -> Int
forall a b. (a, b) -> a
fst Maybe (Int, Int)
mloc,
				((Int, Int) -> Int) -> Maybe (Int, Int) -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, Int) -> Int
forall a b. (a, b) -> b
snd Maybe (Int, Int)
mloc)
			[Note Refact] -> ClientM m [Note Refact]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Note Refact] -> ClientM m [Note Refact])
-> [Note Refact] -> ClientM m [Note Refact]
forall a b. (a -> b) -> a -> b
$ (Region -> Note Refact) -> [Region] -> [Note Refact]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleLocation -> Region -> Note Refact
makeNote (Module
m Module
-> Getting ModuleLocation Module ModuleLocation -> ModuleLocation
forall s a. s -> Getting a s a -> a
^. (ModuleId -> Const ModuleLocation ModuleId)
-> Module -> Const ModuleLocation Module
Lens' Module ModuleId
moduleId ((ModuleId -> Const ModuleLocation ModuleId)
 -> Module -> Const ModuleLocation Module)
-> Getting ModuleLocation ModuleId ModuleLocation
-> Getting ModuleLocation Module ModuleLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting ModuleLocation ModuleId ModuleLocation
Lens' ModuleId ModuleLocation
moduleLocation)) [Region]
localRegions]
runCommand (GhcEval [String]
exprs Maybe FileSource
mfile) = ClientM m [ReplResult String] -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m [ReplResult String] -> ClientM m Value)
-> ClientM m [ReplResult String] -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ do
	Maybe FileSource
mfile' <- (FileSource -> ClientM m FileSource)
-> Maybe FileSource -> ClientM m (Maybe FileSource)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse FileSource -> ClientM m FileSource
forall (m :: * -> *). CommandMonad m => FileSource -> m FileSource
getUpdateFileContents Maybe FileSource
mfile
	case Maybe FileSource
mfile' of
		Maybe FileSource
Nothing -> MGhcT SessionConfig (First DynFlags) (LogT IO) () -> ClientM m ()
forall (m :: * -> *) a. SessionMonad m => GhcM a -> m a
inSessionGhc MGhcT SessionConfig (First DynFlags) (LogT IO) ()
ghciSession
		Just (FileSource Text
f Maybe Text
mcts) -> do
			Module
m <- [String] -> Text -> ClientM m Module
forall (m :: * -> *).
CommandMonad m =>
[String] -> Text -> m Module
setFileSourceSession [] Text
f
			MGhcT SessionConfig (First DynFlags) (LogT IO) () -> ClientM m ()
forall (m :: * -> *) a. SessionMonad m => GhcM a -> m a
inSessionGhc (MGhcT SessionConfig (First DynFlags) (LogT IO) () -> ClientM m ())
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
-> ClientM m ()
forall a b. (a -> b) -> a -> b
$ Module
-> Maybe Text -> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
interpretModule Module
m Maybe Text
mcts
	GhcM [ReplResult String] -> ClientM m [ReplResult String]
forall (m :: * -> *) a. SessionMonad m => GhcM a -> m a
inSessionGhc (GhcM [ReplResult String] -> ClientM m [ReplResult String])
-> GhcM [ReplResult String] -> ClientM m [ReplResult String]
forall a b. (a -> b) -> a -> b
$ (String
 -> MGhcT
      SessionConfig (First DynFlags) (LogT IO) (ReplResult String))
-> [String] -> GhcM [ReplResult String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (MGhcT SessionConfig (First DynFlags) (LogT IO) String
-> MGhcT
     SessionConfig (First DynFlags) (LogT IO) (ReplResult String)
forall (m :: * -> *) a.
(GhcMonad m, MonadCatch m) =>
m a -> m (ReplResult a)
tryRepl (MGhcT SessionConfig (First DynFlags) (LogT IO) String
 -> MGhcT
      SessionConfig (First DynFlags) (LogT IO) (ReplResult String))
-> (String
    -> MGhcT SessionConfig (First DynFlags) (LogT IO) String)
-> String
-> MGhcT
     SessionConfig (First DynFlags) (LogT IO) (ReplResult String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> MGhcT SessionConfig (First DynFlags) (LogT IO) String
forall (m :: * -> *). GhcMonad m => String -> m String
evaluate) [String]
exprs
runCommand (GhcType [String]
exprs Maybe FileSource
mfile) = ClientM m [ReplResult String] -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m [ReplResult String] -> ClientM m Value)
-> ClientM m [ReplResult String] -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ do
	Maybe FileSource
mfile' <- (FileSource -> ClientM m FileSource)
-> Maybe FileSource -> ClientM m (Maybe FileSource)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse FileSource -> ClientM m FileSource
forall (m :: * -> *). CommandMonad m => FileSource -> m FileSource
getUpdateFileContents Maybe FileSource
mfile
	case Maybe FileSource
mfile' of
		Maybe FileSource
Nothing -> MGhcT SessionConfig (First DynFlags) (LogT IO) () -> ClientM m ()
forall (m :: * -> *) a. SessionMonad m => GhcM a -> m a
inSessionGhc MGhcT SessionConfig (First DynFlags) (LogT IO) ()
ghciSession
		Just (FileSource Text
f Maybe Text
mcts) -> do
			Module
m <- [String] -> Text -> ClientM m Module
forall (m :: * -> *).
CommandMonad m =>
[String] -> Text -> m Module
setFileSourceSession [] Text
f
			MGhcT SessionConfig (First DynFlags) (LogT IO) () -> ClientM m ()
forall (m :: * -> *) a. SessionMonad m => GhcM a -> m a
inSessionGhc (MGhcT SessionConfig (First DynFlags) (LogT IO) () -> ClientM m ())
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
-> ClientM m ()
forall a b. (a -> b) -> a -> b
$ Module
-> Maybe Text -> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
interpretModule Module
m Maybe Text
mcts
	GhcM [ReplResult String] -> ClientM m [ReplResult String]
forall (m :: * -> *) a. SessionMonad m => GhcM a -> m a
inSessionGhc (GhcM [ReplResult String] -> ClientM m [ReplResult String])
-> GhcM [ReplResult String] -> ClientM m [ReplResult String]
forall a b. (a -> b) -> a -> b
$ (String
 -> MGhcT
      SessionConfig (First DynFlags) (LogT IO) (ReplResult String))
-> [String] -> GhcM [ReplResult String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (MGhcT SessionConfig (First DynFlags) (LogT IO) String
-> MGhcT
     SessionConfig (First DynFlags) (LogT IO) (ReplResult String)
forall (m :: * -> *) a.
(GhcMonad m, MonadCatch m) =>
m a -> m (ReplResult a)
tryRepl (MGhcT SessionConfig (First DynFlags) (LogT IO) String
 -> MGhcT
      SessionConfig (First DynFlags) (LogT IO) (ReplResult String))
-> (String
    -> MGhcT SessionConfig (First DynFlags) (LogT IO) String)
-> String
-> MGhcT
     SessionConfig (First DynFlags) (LogT IO) (ReplResult String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> MGhcT SessionConfig (First DynFlags) (LogT IO) String
forall (m :: * -> *). GhcMonad m => String -> m String
expressionType) [String]
exprs
runCommand Command
Langs = ClientM m [String] -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m [String] -> ClientM m Value)
-> ClientM m [String] -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ [String] -> ClientM m [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
Compat.languages
runCommand Command
Flags = ClientM m [String] -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m [String] -> ClientM m Value)
-> ClientM m [String] -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ [String] -> ClientM m [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String
"-f" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f |
	String
f <- [String]
Compat.flags,
	String
prefix <- [String
"", String
"no-"]]
runCommand (Link Bool
hold) = ClientM m () -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m () -> ClientM m Value)
-> ClientM m () -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ ClientM m ()
forall (m :: * -> *). CommandMonad m => m ()
commandLink ClientM m () -> ClientM m () -> ClientM m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> ClientM m () -> ClientM m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
hold ClientM m ()
forall (m :: * -> *). CommandMonad m => m ()
commandHold
runCommand Command
StopGhc = ClientM m () -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue (ClientM m () -> ClientM m Value)
-> ClientM m () -> ClientM m Value
forall a b. (a -> b) -> a -> b
$ do
	MGhcT SessionConfig (First DynFlags) (LogT IO) () -> ClientM m ()
forall (m :: * -> *) a. SessionMonad m => GhcM a -> m a
inSessionGhc (MGhcT SessionConfig (First DynFlags) (LogT IO) () -> ClientM m ())
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
-> ClientM m ()
forall a b. (a -> b) -> a -> b
$ do
		[Session SessionConfig (First DynFlags)]
ms <- (SessionConfig -> Bool)
-> MGhcT
     SessionConfig
     (First DynFlags)
     (LogT IO)
     [Session SessionConfig (First DynFlags)]
forall (m :: * -> *) s d.
MonadIO m =>
(s -> Bool) -> MGhcT s d m [Session s d]
findSessionBy (Bool -> SessionConfig -> Bool
forall a b. a -> b -> a
const Bool
True)
		[Session SessionConfig (First DynFlags)]
-> (Session SessionConfig (First DynFlags)
    -> MGhcT SessionConfig (First DynFlags) (LogT IO) ())
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Session SessionConfig (First DynFlags)]
ms ((Session SessionConfig (First DynFlags)
  -> MGhcT SessionConfig (First DynFlags) (LogT IO) ())
 -> MGhcT SessionConfig (First DynFlags) (LogT IO) ())
-> (Session SessionConfig (First DynFlags)
    -> MGhcT SessionConfig (First DynFlags) (LogT IO) ())
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall a b. (a -> b) -> a -> b
$ \Session SessionConfig (First DynFlags)
s -> do
			Level -> Text -> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace (Text -> MGhcT SessionConfig (First DynFlags) (LogT IO) ())
-> Text -> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall a b. (a -> b) -> a -> b
$ Format
"stopping session: {}" Format -> SessionConfig -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ Getting
  SessionConfig
  (Session SessionConfig (First DynFlags))
  SessionConfig
-> Session SessionConfig (First DynFlags) -> SessionConfig
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  SessionConfig
  (Session SessionConfig (First DynFlags))
  SessionConfig
forall s d. Lens' (Session s d) s
sessionKey Session SessionConfig (First DynFlags)
s
			SessionConfig -> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall (m :: * -> *) s d.
(MonadIO m, ExceptionMonad m, Ord s, Monoid d) =>
s -> MGhcT s d m ()
deleteSession (SessionConfig
 -> MGhcT SessionConfig (First DynFlags) (LogT IO) ())
-> SessionConfig
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall a b. (a -> b) -> a -> b
$ Getting
  SessionConfig
  (Session SessionConfig (First DynFlags))
  SessionConfig
-> Session SessionConfig (First DynFlags) -> SessionConfig
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  SessionConfig
  (Session SessionConfig (First DynFlags))
  SessionConfig
forall s d. Lens' (Session s d) s
sessionKey Session SessionConfig (First DynFlags)
s
runCommand Command
Exit = ClientM m () -> ClientM m Value
forall a (m :: * -> *). (ToJSON a, Monad m) => m a -> m Value
toValue ClientM m ()
forall (m :: * -> *). SessionMonad m => m ()
serverExit


targetFilter :: Text -> Maybe Text -> TargetFilter -> (Text, [NamedParam])
targetFilter :: Text -> Maybe Text -> TargetFilter -> (Text, [NamedParam])
targetFilter Text
mtable Maybe Text
_ (TargetProject Text
proj) = (
	Format
"{t}.cabal in (select cabal from projects where name == :project or cabal == :project)" Format -> FormatArg -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ (String
"t" String -> Text -> FormatArg
forall a. Formattable a => String -> a -> FormatArg
~% Text
mtable),
	[Text
":project" Text -> Text -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= Text
proj])
targetFilter Text
mtable Maybe Text
_ (TargetFile Text
f) = (Format
"{t}.file == :file" Format -> FormatArg -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ (String
"t" String -> Text -> FormatArg
forall a. Formattable a => String -> a -> FormatArg
~% Text
mtable), [Text
":file" Text -> Text -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= Text
f])
targetFilter Text
mtable Maybe Text
Nothing (TargetModule Text
nm) = (Format
"{t}.name == :module_name" Format -> FormatArg -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ (String
"t" String -> Text -> FormatArg
forall a. Formattable a => String -> a -> FormatArg
~% Text
mtable), [Text
":module_name" Text -> Text -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= Text
nm])
targetFilter Text
mtable (Just Text
stable) (TargetModule Text
nm) = (
	Format
"({t}.name == :module_name) or ({s}.id in (select e.symbol_id from exports as e, modules as em where e.module_id == em.id and em.name == :module_name))"
		Format -> FormatArg -> Format
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ (String
"t" String -> Text -> FormatArg
forall a. Formattable a => String -> a -> FormatArg
~% Text
mtable)
		Format -> FormatArg -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ (String
"s" String -> Text -> FormatArg
forall a. Formattable a => String -> a -> FormatArg
~% Text
stable),
	[Text
":module_name" Text -> Text -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= Text
nm])
targetFilter Text
mtable Maybe Text
_ (TargetPackage Text
p) = (Format
tpl Format -> FormatArg -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ (String
"t" String -> Text -> FormatArg
forall a. Formattable a => String -> a -> FormatArg
~% Text
mtable), [NamedParam]
params) where
	pkg :: ModulePackage
pkg = ModulePackage -> Maybe ModulePackage -> ModulePackage
forall a. a -> Maybe a -> a
fromMaybe (Text -> ModulePackage
mkPackage Text
p) (String -> Maybe ModulePackage
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
unpack Text
p))
	tpl :: Format
tpl
		| Text -> Bool
T.null (ModulePackage
pkg ModulePackage -> Getting Text ModulePackage Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text ModulePackage Text
Lens' ModulePackage Text
packageVersion) = Format
"{t}.package_name == :package_name"
		| Bool
otherwise = Format
"{t}.package_name == :package_name and {t}.package_version == :package_version"
	params :: [NamedParam]
params
		| Text -> Bool
T.null (ModulePackage
pkg ModulePackage -> Getting Text ModulePackage Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text ModulePackage Text
Lens' ModulePackage Text
packageVersion) = [NamedParam
pname]
		| Bool
otherwise = [NamedParam
pname, NamedParam
pver]
	pname :: NamedParam
pname = Text
":package_name" Text -> Text -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= (ModulePackage
pkg ModulePackage -> Getting Text ModulePackage Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text ModulePackage Text
Lens' ModulePackage Text
packageName)
	pver :: NamedParam
pver = Text
":package_version" Text -> Text -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
:= (ModulePackage
pkg ModulePackage -> Getting Text ModulePackage Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text ModulePackage Text
Lens' ModulePackage Text
packageVersion)
targetFilter Text
mtable Maybe Text
_ TargetFilter
TargetInstalled = (Format
"{t}.package_name is not null" Format -> FormatArg -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ (String
"t" String -> Text -> FormatArg
forall a. Formattable a => String -> a -> FormatArg
~% Text
mtable), [])
targetFilter Text
mtable Maybe Text
_ TargetFilter
TargetSourced = (Format
"{t}.file is not null" Format -> FormatArg -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ (String
"t" String -> Text -> FormatArg
forall a. Formattable a => String -> a -> FormatArg
~% Text
mtable), [])
targetFilter Text
mtable Maybe Text
_ TargetFilter
TargetStandalone = (Format
"{t}.file is not null and {t}.cabal is null" Format -> FormatArg -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ (String
"t" String -> Text -> FormatArg
forall a. Formattable a => String -> a -> FormatArg
~% Text
mtable), [])

targetFilters :: Text -> Maybe Text -> [TargetFilter] -> ([Text], [NamedParam])
targetFilters :: Text -> Maybe Text -> [TargetFilter] -> ([Text], [NamedParam])
targetFilters Text
mtable Maybe Text
stable = ([[NamedParam]] -> [NamedParam])
-> ([Text], [[NamedParam]]) -> ([Text], [NamedParam])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second [[NamedParam]] -> [NamedParam]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (([Text], [[NamedParam]]) -> ([Text], [NamedParam]))
-> ([TargetFilter] -> ([Text], [[NamedParam]]))
-> [TargetFilter]
-> ([Text], [NamedParam])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, [NamedParam])] -> ([Text], [[NamedParam]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Text, [NamedParam])] -> ([Text], [[NamedParam]]))
-> ([TargetFilter] -> [(Text, [NamedParam])])
-> [TargetFilter]
-> ([Text], [[NamedParam]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TargetFilter -> (Text, [NamedParam]))
-> [TargetFilter] -> [(Text, [NamedParam])]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Maybe Text -> TargetFilter -> (Text, [NamedParam])
targetFilter Text
mtable Maybe Text
stable)

likePattern :: SearchQuery -> Text
likePattern :: SearchQuery -> Text
likePattern (SearchQuery Text
input SearchType
stype) = case SearchType
stype of
	SearchType
SearchExact -> Text
escapedInput
	SearchType
SearchPrefix -> Text
escapedInput Text -> Text -> Text
`T.append` Text
"%"
	SearchType
SearchInfix -> Text
"%" Text -> Text -> Text
`T.append` Text
escapedInput Text -> Text -> Text
`T.append` Text
"%"
	SearchType
SearchSuffix -> Text
"%" Text -> Text -> Text
`T.append` Text
escapedInput
	where
		escapedInput :: Text
escapedInput = Text -> Text
escapeLike Text
input

instance ToJSON Log.Message where
	toJSON :: Message -> Value
toJSON Message
m = [Pair] -> Value
object [
		Text
"time" Text -> ZonedTime -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Message -> ZonedTime
Log.messageTime Message
m,
		Text
"level" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Level -> String
forall a. Show a => a -> String
show (Message -> Level
Log.messageLevel Message
m),
		Text
"component" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Component -> String
forall a. Show a => a -> String
show (Message -> Component
Log.messageComponent Message
m),
		Text
"scope" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Scope -> String
forall a. Show a => a -> String
show (Message -> Scope
Log.messageScope Message
m),
		Text
"text" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Message -> Text
Log.messageText Message
m]

instance FromJSON Log.Message where
	parseJSON :: Value -> Parser Message
parseJSON = String -> (Object -> Parser Message) -> Value -> Parser Message
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"log-message" ((Object -> Parser Message) -> Value -> Parser Message)
-> (Object -> Parser Message) -> Value -> Parser Message
forall a b. (a -> b) -> a -> b
$ \Object
v -> ZonedTime -> Level -> Component -> Scope -> Text -> Message
Log.Message (ZonedTime -> Level -> Component -> Scope -> Text -> Message)
-> Parser ZonedTime
-> Parser (Level -> Component -> Scope -> Text -> Message)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
		(Object
v Object -> Text -> Parser ZonedTime
forall a. FromJSON a => Object -> Text -> Parser a
.:: Text
"time") Parser (Level -> Component -> Scope -> Text -> Message)
-> Parser Level -> Parser (Component -> Scope -> Text -> Message)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
		((Object
v Object -> Text -> Parser String
forall a. FromJSON a => Object -> Text -> Parser a
.:: Text
"level") Parser String -> (String -> Parser Level) -> Parser Level
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Parser Level
-> (Level -> Parser Level) -> Maybe Level -> Parser Level
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Parser Level
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid level") Level -> Parser Level
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Level -> Parser Level)
-> (String -> Maybe Level) -> String -> Parser Level
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe Level
forall a. Read a => String -> Maybe a
readMaybe) Parser (Component -> Scope -> Text -> Message)
-> Parser Component -> Parser (Scope -> Text -> Message)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
		(String -> Component
forall a. Read a => String -> a
read (String -> Component) -> Parser String -> Parser Component
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
v Object -> Text -> Parser String
forall a. FromJSON a => Object -> Text -> Parser a
.:: Text
"component")) Parser (Scope -> Text -> Message)
-> Parser Scope -> Parser (Text -> Message)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
		(String -> Scope
forall a. Read a => String -> a
read (String -> Scope) -> Parser String -> Parser Scope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
v Object -> Text -> Parser String
forall a. FromJSON a => Object -> Text -> Parser a
.:: Text
"scope")) Parser (Text -> Message) -> Parser Text -> Parser Message
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
		(Object
v Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.:: Text
"text")


-- | Run check
runCheck :: CommandMonad m => [String] -> Bool -> FileSource -> m [Tools.Note Tools.OutputMessage]
runCheck :: [String] -> Bool -> FileSource -> m [Note OutputMessage]
runCheck [String]
ghcs' Bool
clear = FileSource -> m FileSource
forall (m :: * -> *). CommandMonad m => FileSource -> m FileSource
getUpdateFileContents (FileSource -> m FileSource)
-> (FileSource -> m [Note OutputMessage])
-> FileSource
-> m [Note OutputMessage]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> FileSource -> m [Note OutputMessage]
forall (m :: * -> *).
CommandMonad m =>
FileSource -> m [Note OutputMessage]
check' where
	check' :: FileSource -> m [Note OutputMessage]
check' (FileSource Text
file Maybe Text
mcts) = Text -> m [Note OutputMessage] -> m [Note OutputMessage]
forall (m :: * -> *) a.
(MonadLog m, HasCallStack) =>
Text -> m a -> m a
Log.scope Text
"run-check" (m [Note OutputMessage] -> m [Note OutputMessage])
-> m [Note OutputMessage] -> m [Note OutputMessage]
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
"setting file source session for {}" Format -> Text -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ Text
file
		Session
sess <- m Session
forall (m :: * -> *). SessionMonad m => m Session
getSession
		Module
m <- [String] -> Text -> m Module
forall (m :: * -> *).
CommandMonad m =>
[String] -> Text -> m Module
setFileSourceSession [String]
ghcs' Text
file
		Level -> Text -> m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace Text
"file source session set"
		[Note OutputMessage]
ns <- GhcM [Note OutputMessage] -> m [Note OutputMessage]
forall (m :: * -> *) a. SessionMonad m => GhcM a -> m a
inSessionGhc (GhcM [Note OutputMessage] -> m [Note OutputMessage])
-> GhcM [Note OutputMessage] -> m [Note OutputMessage]
forall a b. (a -> b) -> a -> b
$ do
			Bool
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
-> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
clear MGhcT SessionConfig (First DynFlags) (LogT IO) ()
forall (m :: * -> *). GhcMonad m => m ()
clearTargets
			Session
-> [ModuleLocation]
-> GhcM [Note OutputMessage]
-> GhcM [Note OutputMessage]
forall a. Session -> [ModuleLocation] -> GhcM a -> GhcM a
Update.cacheGhcWarnings Session
sess [Module
m Module
-> Getting ModuleLocation Module ModuleLocation -> ModuleLocation
forall s a. s -> Getting a s a -> a
^. (ModuleId -> Const ModuleLocation ModuleId)
-> Module -> Const ModuleLocation Module
Lens' Module ModuleId
moduleId ((ModuleId -> Const ModuleLocation ModuleId)
 -> Module -> Const ModuleLocation Module)
-> Getting ModuleLocation ModuleId ModuleLocation
-> Getting ModuleLocation Module ModuleLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting ModuleLocation ModuleId ModuleLocation
Lens' ModuleId ModuleLocation
moduleLocation] (GhcM [Note OutputMessage] -> GhcM [Note OutputMessage])
-> GhcM [Note OutputMessage] -> GhcM [Note OutputMessage]
forall a b. (a -> b) -> a -> b
$
				Module -> Maybe Text -> GhcM [Note OutputMessage]
forall (m :: * -> *).
(MonadLog m, GhcMonad m) =>
Module -> Maybe Text -> m [Note OutputMessage]
Check.check Module
m Maybe Text
mcts
		if [Note OutputMessage] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Note OutputMessage]
ns
			then do
				ServerM IO () -> m ()
forall (m :: * -> *) a. SessionMonad m => ServerM IO a -> m a
inSessionUpdater (ServerM IO () -> m ()) -> ServerM IO () -> m ()
forall a b. (a -> b) -> a -> b
$ () -> ServerM IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- wait until cache updated
				[Note OutputMessage]
ns' <- [ModuleLocation] -> m [Note OutputMessage]
forall (m :: * -> *).
SessionMonad m =>
[ModuleLocation] -> m [Note OutputMessage]
Update.cachedWarnings [Module
m Module
-> Getting ModuleLocation Module ModuleLocation -> ModuleLocation
forall s a. s -> Getting a s a -> a
^. (ModuleId -> Const ModuleLocation ModuleId)
-> Module -> Const ModuleLocation Module
Lens' Module ModuleId
moduleId ((ModuleId -> Const ModuleLocation ModuleId)
 -> Module -> Const ModuleLocation Module)
-> Getting ModuleLocation ModuleId ModuleLocation
-> Getting ModuleLocation Module ModuleLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting ModuleLocation ModuleId ModuleLocation
Lens' ModuleId ModuleLocation
moduleLocation]
				Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Note OutputMessage] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Note OutputMessage]
ns') (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
					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
"returning {} cached warnings for {}" Format -> Int -> Format
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ [Note OutputMessage] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Note OutputMessage]
ns' Format -> Text -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ Text
file
				[Note OutputMessage] -> m [Note OutputMessage]
forall (m :: * -> *) a. Monad m => a -> m a
return [Note OutputMessage]
ns'
			else [Note OutputMessage] -> m [Note OutputMessage]
forall (m :: * -> *) a. Monad m => a -> m a
return [Note OutputMessage]
ns

-- Helper functions

-- | Canonicalize paths
findPath :: (CommandMonad m, Paths a) => a -> m a
findPath :: a -> m a
findPath = (String -> m String) -> a -> m a
forall a. Paths a => Traversal' a String
paths String -> m String
forall (m :: * -> *). CommandMonad m => String -> m String
findPath' where
	findPath' :: CommandMonad m => FilePath -> m FilePath
	findPath' :: String -> m String
findPath' String
f = do
		String
r <- m String
forall (m :: * -> *). CommandMonad m => m String
commandRoot
		IO String -> m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ String -> IO String
canonicalizePath (String -> String
normalise (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ if String -> Bool
isRelative String
f then String
r String -> String -> String
</> String
f else String
f)

-- | Find sandbox by path
findSandbox :: CommandMonad m => Path -> m Sandbox
findSandbox :: Text -> m Sandbox
findSandbox Text
fpath = do
	Text
fpath' <- Text -> m Text
forall (m :: * -> *) a. (CommandMonad m, Paths a) => a -> m a
findPath Text
fpath
	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
$ Text -> IO (Maybe Sandbox)
S.findSandbox Text
fpath'
	m Sandbox -> (Sandbox -> m Sandbox) -> Maybe Sandbox -> m Sandbox
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (HsDevError -> m Sandbox
forall (m :: * -> *) a. MonadThrow m => HsDevError -> m a
hsdevError (HsDevError -> m Sandbox) -> HsDevError -> m Sandbox
forall a b. (a -> b) -> a -> b
$ Text -> HsDevError
FileNotFound Text
fpath') Sandbox -> m Sandbox
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Sandbox
sbox

-- | Check if source file up to date
sourceUpToDate :: CommandMonad m => Path -> m Bool
sourceUpToDate :: Text -> m Bool
sourceUpToDate Text
fpath = do
	Text
fpath' <- Text -> m Text
forall (m :: * -> *) a. (CommandMonad m, Paths a) => a -> m a
findPath Text
fpath
	[Inspection]
insps <- Query -> Only Text -> m [Inspection]
forall q r (m :: * -> *).
(ToRow q, FromRow r, SessionMonad m) =>
Query -> q -> m [r]
query @_ @Inspection Query
"select inspection_time, inspection_opts from modules where file = ?;" (Text -> Only Text
forall a. a -> Only a
Only Text
fpath')
	Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Inspection] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Inspection]
insps Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Level -> Text -> m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Warning (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Format
"multiple modules with same file = {}" Format -> Text -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ Text
fpath'
	m Bool -> (Inspection -> m Bool) -> Maybe Inspection -> m Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
		(Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
		(ModuleLocation -> [String] -> Inspection -> m Bool
forall (m :: * -> *).
SessionMonad m =>
ModuleLocation -> [String] -> Inspection -> m Bool
upToDate (Text -> Maybe Project -> ModuleLocation
FileModule Text
fpath' Maybe Project
forall a. Maybe a
Nothing) [])
		([Inspection] -> Maybe Inspection
forall a. [a] -> Maybe a
listToMaybe [Inspection]
insps)

-- | Get source file
-- refineSourceFile :: CommandMonad m => Path -> m Path
-- refineSourceFile fpath = do
-- 	fpath' <- findPath fpath
-- 	fs <- liftM (map fromOnly) $ query "select file from modules where file == ?;" (Only fpath')
-- 	case fs of
-- 		[] -> hsdevError (NotInspected $ FileModule fpath' Nothing)
-- 		(f:_) -> do
-- 			when (length fs > 1) $ Log.sendLog Log.Warning $ "multiple modules with same file = {}" ~~ fpath'
-- 			return f

-- | Get module by source
refineSourceModule :: CommandMonad m => Path -> m Module
refineSourceModule :: Text -> m Module
refineSourceModule Text
fpath = do
	Text
fpath' <- Text -> m Text
forall (m :: * -> *) a. (CommandMonad m, Paths a) => a -> m a
findPath Text
fpath
	[(Int, Maybe Text)]
ids <- Query -> Only Text -> m [(Int, Maybe Text)]
forall q r (m :: * -> *).
(ToRow q, FromRow r, SessionMonad m) =>
Query -> q -> m [r]
query Query
"select id, cabal from modules where file == ?;" (Text -> Only Text
forall a. a -> Only a
Only Text
fpath')
	case [(Int, Maybe Text)]
ids of
		[] -> HsDevError -> m Module
forall (m :: * -> *) a. MonadThrow m => HsDevError -> m a
hsdevError (ModuleLocation -> HsDevError
NotInspected (ModuleLocation -> HsDevError) -> ModuleLocation -> HsDevError
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Project -> ModuleLocation
FileModule Text
fpath' Maybe Project
forall a. Maybe a
Nothing)
		((Int
i, Maybe Text
mcabal):[(Int, Maybe Text)]
_) -> do
			Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([(Int, Maybe Text)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, Maybe Text)]
ids Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Level -> Text -> m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Warning (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Format
"multiple modules with same file = {}" Format -> Text -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ Text
fpath'
			Module
m <- Int -> m Module
forall (m :: * -> *). SessionMonad m => Int -> m Module
SQLite.loadModule Int
i
			case Maybe Text
mcabal of
				Maybe Text
Nothing -> do
					[Inspection
insp] <- Query -> Only Int -> m [Inspection]
forall q r (m :: * -> *).
(ToRow q, FromRow r, SessionMonad m) =>
Query -> q -> m [r]
query @_ @Inspection Query
"select inspection_time, inspection_opts from modules where id = ?;" (Int -> Only Int
forall a. a -> Only a
Only Int
i)
					Bool
fresh' <- ModuleLocation -> [String] -> Inspection -> m Bool
forall (m :: * -> *).
SessionMonad m =>
ModuleLocation -> [String] -> Inspection -> m Bool
upToDate (Module
m Module
-> Getting ModuleLocation Module ModuleLocation -> ModuleLocation
forall s a. s -> Getting a s a -> a
^. (ModuleId -> Const ModuleLocation ModuleId)
-> Module -> Const ModuleLocation Module
Lens' Module ModuleId
moduleId ((ModuleId -> Const ModuleLocation ModuleId)
 -> Module -> Const ModuleLocation Module)
-> Getting ModuleLocation ModuleId ModuleLocation
-> Getting ModuleLocation Module ModuleLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting ModuleLocation ModuleId ModuleLocation
Lens' ModuleId ModuleLocation
moduleLocation) [] Inspection
insp
					if Bool
fresh'
						then Module -> m Module
forall (m :: * -> *) a. Monad m => a -> m a
return Module
m
						else do
							[(String, String)]
defs <- (Session -> [(String, String)]) -> m [(String, String)]
forall (m :: * -> *) a. SessionMonad m => (Session -> a) -> m a
askSession Session -> [(String, String)]
sessionDefines
							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))
getFileContents Text
fpath'
							Inspected ModuleLocation ModuleTag Preloaded
ip' <- 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 (Module
m Module
-> Getting ModuleLocation Module ModuleLocation -> ModuleLocation
forall s a. s -> Getting a s a -> a
^. (ModuleId -> Const ModuleLocation ModuleId)
-> Module -> Const ModuleLocation Module
Lens' Module ModuleId
moduleId ((ModuleId -> Const ModuleLocation ModuleId)
 -> Module -> Const ModuleLocation Module)
-> Getting ModuleLocation ModuleId ModuleLocation
-> Getting ModuleLocation Module ModuleLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting ModuleLocation ModuleId ModuleLocation
Lens' ModuleId ModuleLocation
moduleLocation) (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
$ 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 (Module
m Module -> Getting Text Module Text -> Text
forall s a. s -> Getting a s a -> a
^. (ModuleId -> Const Text ModuleId) -> Module -> Const Text Module
Lens' Module ModuleId
moduleId ((ModuleId -> Const Text ModuleId) -> Module -> Const Text Module)
-> ((Text -> Const Text Text) -> ModuleId -> Const Text ModuleId)
-> Getting Text Module Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const Text Text) -> ModuleId -> Const Text ModuleId
Lens' ModuleId Text
moduleName) [(String, String)]
defs [] Maybe Text
mcts
							case Inspected ModuleLocation ModuleTag Preloaded
ip' Inspected ModuleLocation ModuleTag Preloaded
-> Getting
     (First Preloaded)
     (Inspected ModuleLocation ModuleTag Preloaded)
     Preloaded
-> Maybe Preloaded
forall s a. s -> Getting (First a) s a -> Maybe a
^? 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 of
								Just Preloaded
p' -> Module -> m Module
forall (m :: * -> *) a. Monad m => a -> m a
return (Module -> m Module) -> Module -> m Module
forall a b. (a -> b) -> a -> b
$ ASetter Module Module [Import] [Import]
-> [Import] -> Module -> Module
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Module Module [Import] [Import]
Lens' Module [Import]
moduleImports (Preloaded
p' Preloaded -> Getting [Import] Preloaded [Import] -> [Import]
forall s a. s -> Getting a s a -> a
^. (Module -> Const [Import] Module)
-> Preloaded -> Const [Import] Preloaded
Lens' Preloaded Module
asModule ((Module -> Const [Import] Module)
 -> Preloaded -> Const [Import] Preloaded)
-> (([Import] -> Const [Import] [Import])
    -> Module -> Const [Import] Module)
-> Getting [Import] Preloaded [Import]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Import] -> Const [Import] [Import])
-> Module -> Const [Import] Module
Lens' Module [Import]
moduleImports) Module
m
								Maybe Preloaded
Nothing -> Module -> m Module
forall (m :: * -> *) a. Monad m => a -> m a
return Module
m
				Just Text
cabal' -> do
					Project
proj' <- Text -> m Project
forall (m :: * -> *). SessionMonad m => Text -> m Project
SQLite.loadProject Text
cabal'
					Module -> m Module
forall (m :: * -> *) a. Monad m => a -> m a
return (Module -> m Module) -> Module -> m Module
forall a b. (a -> b) -> a -> b
$ ((Maybe Project -> Identity (Maybe Project))
 -> Module -> Identity Module)
-> Maybe Project -> Module -> Module
forall s t a b. ASetter s t a b -> b -> s -> t
set ((ModuleId -> Identity ModuleId) -> Module -> Identity Module
Lens' Module ModuleId
moduleId ((ModuleId -> Identity ModuleId) -> Module -> Identity Module)
-> ((Maybe Project -> Identity (Maybe Project))
    -> ModuleId -> Identity ModuleId)
-> (Maybe Project -> Identity (Maybe Project))
-> Module
-> Identity Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleLocation -> Identity ModuleLocation)
-> ModuleId -> Identity ModuleId
Lens' ModuleId ModuleLocation
moduleLocation ((ModuleLocation -> Identity ModuleLocation)
 -> ModuleId -> Identity ModuleId)
-> ((Maybe Project -> Identity (Maybe Project))
    -> ModuleLocation -> Identity ModuleLocation)
-> (Maybe Project -> Identity (Maybe Project))
-> ModuleId
-> Identity ModuleId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Project -> Identity (Maybe Project))
-> ModuleLocation -> Identity ModuleLocation
Traversal' ModuleLocation (Maybe Project)
moduleProject) (Project -> Maybe Project
forall a. a -> Maybe a
Just Project
proj') Module
m

-- | Get update file contents
getUpdateFileContents :: CommandMonad m => FileSource -> m FileSource
getUpdateFileContents :: FileSource -> m FileSource
getUpdateFileContents (FileSource Text
fpath Maybe Text
Nothing) = (Maybe (POSIXTime, Text) -> FileSource)
-> m (Maybe (POSIXTime, Text)) -> m FileSource
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Maybe Text -> FileSource
FileSource Text
fpath (Maybe Text -> FileSource)
-> (Maybe (POSIXTime, Text) -> Maybe Text)
-> Maybe (POSIXTime, Text)
-> FileSource
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((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) (Text -> m (Maybe (POSIXTime, Text))
forall (m :: * -> *).
SessionMonad m =>
Text -> m (Maybe (POSIXTime, Text))
getFileContents Text
fpath)
getUpdateFileContents fcts :: FileSource
fcts@(FileSource Text
fpath Maybe Text
mcts) = do
	Text -> Maybe Text -> m ()
forall (m :: * -> *). SessionMonad m => Text -> Maybe Text -> m ()
serverSetFileContents Text
fpath Maybe Text
mcts
	FileSource -> m FileSource
forall (m :: * -> *) a. Monad m => a -> m a
return FileSource
fcts

-- | Set session by source
setFileSourceSession :: CommandMonad m => [String] -> Path -> m Module
setFileSourceSession :: [String] -> Text -> m Module
setFileSourceSession [String]
opts Text
fpath = do
	Module
m <- Text -> m Module
forall (m :: * -> *). CommandMonad m => Text -> m Module
refineSourceModule Text
fpath
	MGhcT SessionConfig (First DynFlags) (LogT IO) () -> m ()
forall (m :: * -> *) a. SessionMonad m => GhcM a -> m a
inSessionGhc (MGhcT SessionConfig (First DynFlags) (LogT IO) () -> m ())
-> MGhcT SessionConfig (First DynFlags) (LogT IO) () -> m ()
forall a b. (a -> b) -> a -> b
$ [String]
-> Module -> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
targetSession [String]
opts Module
m
	Module -> m Module
forall (m :: * -> *) a. Monad m => a -> m a
return Module
m

-- | Ensure package exists
-- refinePackage :: CommandMonad m => Text -> m Text
-- refinePackage pkg = do
-- 	[(Only exists)] <- query "select count(*) > 0 from package_dbs where package_name == ?;" (Only pkg)
-- 	when (not exists) $ hsdevError (PackageNotFound pkg)
-- 	return pkg

-- | Get list of enumerated sandboxes
getSandboxes :: CommandMonad m => [Path] -> m [Sandbox]
getSandboxes :: [Text] -> m [Sandbox]
getSandboxes = (Text -> m Sandbox) -> [Text] -> m [Sandbox]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Text -> m Text
forall (m :: * -> *) a. (CommandMonad m, Paths a) => a -> m a
findPath (Text -> m Text) -> (Text -> m Sandbox) -> Text -> m Sandbox
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Text -> m Sandbox
forall (m :: * -> *). CommandMonad m => Text -> m Sandbox
findSandbox)

-- | Find project by name or path
findProject :: CommandMonad m => Text -> m Project
findProject :: Text -> m Project
findProject Text
proj = do
	Text
proj' <- (Text -> Text) -> m Text -> m Text
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Text -> Text
addCabal (m Text -> m Text) -> m Text -> m Text
forall a b. (a -> b) -> a -> b
$ Text -> m Text
forall (m :: * -> *) a. (CommandMonad m, Paths a) => a -> m a
findPath Text
proj
	[Text]
ps <- ([Only Text] -> [Text]) -> m [Only Text] -> m [Text]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((Only Text -> Text) -> [Only Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Only Text -> Text
forall a. Only a -> a
fromOnly) (m [Only Text] -> m [Text]) -> m [Only Text] -> m [Text]
forall a b. (a -> b) -> a -> b
$ Query -> (String, Text) -> m [Only Text]
forall q r (m :: * -> *).
(ToRow q, FromRow r, SessionMonad m) =>
Query -> q -> m [r]
query Query
"select cabal from projects where (cabal == ?) or (name == ?);" (Getting String Text String -> Text -> String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting String Text String
Lens' Text String
path Text
proj', Text
proj)
	case [Text]
ps of
		[] -> HsDevError -> m Project
forall (m :: * -> *) a. MonadThrow m => HsDevError -> m a
hsdevError (HsDevError -> m Project) -> HsDevError -> m Project
forall a b. (a -> b) -> a -> b
$ Text -> HsDevError
ProjectNotFound Text
proj
		[Text]
_ -> Text -> m Project
forall (m :: * -> *). SessionMonad m => Text -> m Project
SQLite.loadProject ([Text] -> Text
forall a. [a] -> a
head [Text]
ps)
	where
		addCabal :: Text -> Text
addCabal Text
p
			| String -> String
takeExtension (Getting String Text String -> Text -> String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting String Text String
Lens' Text String
path Text
p) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".cabal" = Text
p
			| Bool
otherwise = ASetter Text Text String String
-> (String -> String) -> Text -> Text
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Text Text String String
Lens' Text String
path (\String
p' -> String
p' String -> String -> String
</> (String -> String
takeBaseName String
p' String -> String -> String
<.> String
"cabal")) Text
p

-- | Run DB update action
updateProcess :: ServerMonadBase m => Update.UpdateOptions -> [Update.UpdateM IO ()] -> ClientM m ()
updateProcess :: UpdateOptions -> [UpdateM IO ()] -> ClientM m ()
updateProcess UpdateOptions
uopts [UpdateM IO ()]
acts = (forall a. IO a -> m a) -> ClientM IO () -> ClientM m ()
forall k (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
hoist forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ClientM IO () -> ClientM m ()) -> ClientM IO () -> ClientM m ()
forall a b. (a -> b) -> a -> b
$ do
	CommandOptions
copts <- ClientM IO CommandOptions
forall (m :: * -> *). CommandMonad m => m CommandOptions
getOptions
	ServerM IO () -> ClientM IO ()
forall (m :: * -> *) a. SessionMonad m => ServerM IO a -> m a
inSessionUpdater (ServerM IO () -> ClientM IO ()) -> ServerM IO () -> ClientM IO ()
forall a b. (a -> b) -> a -> b
$ (forall a. ReaderT CommandOptions IO a -> IO a)
-> ServerM (ReaderT CommandOptions IO) () -> ServerM IO ()
forall k (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
hoist ((ReaderT CommandOptions IO a -> CommandOptions -> IO a)
-> CommandOptions -> ReaderT CommandOptions IO a -> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT CommandOptions IO a -> CommandOptions -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT CommandOptions
copts) (ServerM (ReaderT CommandOptions IO) () -> ServerM IO ())
-> ServerM (ReaderT CommandOptions IO) () -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ ClientM IO () -> ServerM (ReaderT CommandOptions IO) ()
forall (m :: * -> *) a.
ClientM m a -> ServerM (ReaderT CommandOptions m) a
runClientM (ClientM IO () -> ServerM (ReaderT CommandOptions IO) ())
-> ClientM IO () -> ServerM (ReaderT CommandOptions IO) ()
forall a b. (a -> b) -> a -> b
$ (UpdateM IO () -> ClientM IO ())
-> [UpdateM IO ()] -> ClientM IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (UpdateOptions -> UpdateM IO () -> ClientM IO ()
forall (m :: * -> *) a.
ServerMonadBase m =>
UpdateOptions -> UpdateM m a -> ClientM m a
Update.runUpdate UpdateOptions
uopts (UpdateM IO () -> ClientM IO ())
-> (UpdateM IO () -> UpdateM IO ())
-> UpdateM IO ()
-> ClientM IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UpdateM IO () -> UpdateM IO ()
forall (m :: * -> *). MonadLog m => m () -> m ()
runAct) [UpdateM IO ()]
acts
	where
		runAct :: m () -> m ()
runAct m ()
act = m () -> (HsDevError -> m ()) -> m ()
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch m ()
act HsDevError -> m ()
forall (m :: * -> *). MonadLog m => HsDevError -> m ()
onError
		onError :: HsDevError -> m ()
onError HsDevError
e = 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
"{}" Format -> HsDevError -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ (HsDevError
e :: HsDevError)