{-# OPTIONS_GHC -Wno-orphans #-}
module Development.IDE.Main
(Arguments(..)
,defaultArguments
,Command(..)
,IdeCommand(..)
,isLSP
,commandP
,defaultMain
,testing
,Log(..)
) where
import Control.Concurrent.Extra (withNumCapabilities)
import Control.Concurrent.MVar (newEmptyMVar,
putMVar, tryReadMVar)
import Control.Concurrent.STM.Stats (dumpSTMStats)
import Control.Exception.Safe (SomeException,
catchAny,
displayException)
import Control.Monad.Extra (concatMapM, unless,
when)
import Control.Monad.IO.Class (liftIO)
import qualified Data.Aeson as J
import Data.Coerce (coerce)
import Data.Default (Default (def))
import Data.Hashable (hashed)
import qualified Data.HashMap.Strict as HashMap
import Data.List.Extra (intercalate,
isPrefixOf, nubOrd,
partition)
import Data.Maybe (catMaybes, isJust)
import qualified Data.Text as T
import Development.IDE (Action,
Priority (Debug, Error),
Rules, hDuplicateTo')
import Development.IDE.Core.Debouncer (Debouncer,
newAsyncDebouncer)
import Development.IDE.Core.FileStore (isWatchSupported,
setSomethingModified)
import Development.IDE.Core.IdeConfiguration (IdeConfiguration (..),
modifyClientSettings,
registerIdeConfiguration)
import Development.IDE.Core.OfInterest (FileOfInterestStatus (OnDisk),
kick,
setFilesOfInterest)
import Development.IDE.Core.Rules (mainRule)
import qualified Development.IDE.Core.Rules as Rules
import Development.IDE.Core.RuleTypes (GenerateCore (GenerateCore),
GetHieAst (GetHieAst),
TypeCheck (TypeCheck))
import Development.IDE.Core.Service (initialise,
runAction)
import qualified Development.IDE.Core.Service as Service
import Development.IDE.Core.Shake (IdeState (shakeExtras),
ThreadQueue (tLoaderQueue),
shakeSessionInit,
uses)
import qualified Development.IDE.Core.Shake as Shake
import Development.IDE.Graph (action)
import Development.IDE.LSP.LanguageServer (runLanguageServer,
runWithWorkerThreads,
setupLSP)
import qualified Development.IDE.LSP.LanguageServer as LanguageServer
import Development.IDE.Main.HeapStats (withHeapStats)
import qualified Development.IDE.Main.HeapStats as HeapStats
import qualified Development.IDE.Monitoring.OpenTelemetry as OpenTelemetry
import Development.IDE.Plugin (Plugin (pluginHandlers, pluginModifyDynflags, pluginRules))
import Development.IDE.Plugin.HLS (asGhcIdePlugin)
import qualified Development.IDE.Plugin.HLS as PluginHLS
import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde
import qualified Development.IDE.Plugin.Test as Test
import Development.IDE.Session (SessionLoadingOptions,
getHieDbLoc,
loadSessionWithOptions,
retryOnSqliteBusy,
setInitialDynFlags)
import qualified Development.IDE.Session as Session
import Development.IDE.Types.Location (NormalizedUri,
toNormalizedFilePath')
import Development.IDE.Types.Monitoring (Monitoring)
import Development.IDE.Types.Options (IdeGhcSession,
IdeOptions (optCheckParents, optCheckProject, optReportProgress, optRunSubset),
IdeTesting (IdeTesting),
clientSupportsProgress,
defaultIdeOptions,
optModifyDynFlags,
optTesting)
import Development.IDE.Types.Shake (WithHieDb,
toNoFileKey)
import GHC.Conc (getNumProcessors)
import GHC.IO.Encoding (setLocaleEncoding)
import GHC.IO.Handle (hDuplicate)
import HIE.Bios.Cradle (findCradle)
import qualified HieDb.Run as HieDb
import Ide.Logger (Pretty (pretty),
Priority (Info),
Recorder,
WithPriority,
cmapWithPrio,
logWith, nest, vsep,
(<+>))
import Ide.Plugin.Config (CheckParents (NeverCheck),
Config, checkParents,
checkProject,
getConfigFromNotification)
import Ide.PluginUtils (allLspCmdIds',
getProcessID,
idePluginsToPluginDesc,
pluginDescToIdePlugins)
import Ide.Types (IdeCommand (IdeCommand),
IdePlugins,
PluginDescriptor (PluginDescriptor, pluginCli),
PluginId (PluginId),
ipMap, pluginId)
import qualified Language.LSP.Server as LSP
import Numeric.Natural (Natural)
import Options.Applicative hiding (action)
import qualified System.Directory.Extra as IO
import System.Exit (ExitCode (ExitFailure),
exitWith)
import System.FilePath (takeExtension,
takeFileName)
import System.IO (BufferMode (LineBuffering, NoBuffering),
Handle, hFlush,
hPutStrLn,
hSetBuffering,
hSetEncoding, stderr,
stdin, stdout, utf8)
import System.Random (newStdGen)
import System.Time.Extra (Seconds, offsetTime,
showDuration)
data Log
= LogHeapStats !HeapStats.Log
| LogLspStart [PluginId]
| LogLspStartDuration !Seconds
| LogShouldRunSubset !Bool
| LogSetInitialDynFlagsException !SomeException
| LogConfigurationChange T.Text
| LogService Service.Log
| LogShake Shake.Log
| LogGhcIde GhcIde.Log
| LogLanguageServer LanguageServer.Log
| LogSession Session.Log
| LogPluginHLS PluginHLS.Log
| LogRules Rules.Log
deriving Int -> Log -> ShowS
[Log] -> ShowS
Log -> String
(Int -> Log -> ShowS)
-> (Log -> String) -> ([Log] -> ShowS) -> Show Log
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Log -> ShowS
showsPrec :: Int -> Log -> ShowS
$cshow :: Log -> String
show :: Log -> String
$cshowList :: [Log] -> ShowS
showList :: [Log] -> ShowS
Show
instance Pretty Log where
pretty :: forall ann. Log -> Doc ann
pretty = \case
LogHeapStats Log
msg -> Log -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Log -> Doc ann
pretty Log
msg
LogLspStart [PluginId]
pluginIds ->
Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
[ Doc ann
"Starting LSP server..."
, Doc ann
"If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option!"
, Doc ann
"PluginIds:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Text] -> Doc ann
forall ann. [Text] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (forall a b. Coercible a b => a -> b
forall a b. Coercible a b => a -> b
coerce @_ @[T.Text] [PluginId]
pluginIds)
]
LogLspStartDuration Seconds
duration ->
Doc ann
"Started LSP server in" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Seconds -> String
showDuration Seconds
duration)
LogShouldRunSubset Bool
shouldRunSubset ->
Doc ann
"shouldRunSubset:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Bool -> Doc ann
forall ann. Bool -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Bool
shouldRunSubset
LogSetInitialDynFlagsException SomeException
e ->
Doc ann
"setInitialDynFlags:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e)
LogConfigurationChange Text
msg -> Doc ann
"Configuration changed:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
msg
LogService Log
msg -> Log -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Log -> Doc ann
pretty Log
msg
LogShake Log
msg -> Log -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Log -> Doc ann
pretty Log
msg
LogGhcIde Log
msg -> Log -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Log -> Doc ann
pretty Log
msg
LogLanguageServer Log
msg -> Log -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Log -> Doc ann
pretty Log
msg
LogSession Log
msg -> Log -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Log -> Doc ann
pretty Log
msg
LogPluginHLS Log
msg -> Log -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Log -> Doc ann
pretty Log
msg
LogRules Log
msg -> Log -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Log -> Doc ann
pretty Log
msg
data Command
= Check [FilePath]
| Db {Command -> Options
hieOptions :: HieDb.Options, Command -> Command
hieCommand :: HieDb.Command}
| LSP
| Custom {Command -> IdeCommand IdeState
ideCommand :: IdeCommand IdeState}
deriving Int -> Command -> ShowS
[Command] -> ShowS
Command -> String
(Int -> Command -> ShowS)
-> (Command -> String) -> ([Command] -> ShowS) -> Show Command
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Command -> ShowS
showsPrec :: Int -> Command -> ShowS
$cshow :: Command -> String
show :: Command -> String
$cshowList :: [Command] -> ShowS
showList :: [Command] -> ShowS
Show
deriving instance Show HieDb.Command
deriving instance Show HieDb.Options
isLSP :: Command -> Bool
isLSP :: Command -> Bool
isLSP Command
LSP = Bool
True
isLSP Command
_ = Bool
False
commandP :: IdePlugins IdeState -> Parser Command
commandP :: IdePlugins IdeState -> Parser Command
commandP IdePlugins IdeState
plugins =
Mod CommandFields Command -> Parser Command
forall a. Mod CommandFields a -> Parser a
hsubparser(String -> ParserInfo Command -> Mod CommandFields Command
forall a. String -> ParserInfo a -> Mod CommandFields a
command String
"typecheck" (Parser Command -> InfoMod Command -> ParserInfo Command
forall a. Parser a -> InfoMod a -> ParserInfo a
info ([String] -> Command
Check ([String] -> Command) -> Parser [String] -> Parser Command
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [String]
fileCmd) InfoMod Command
forall {a}. InfoMod a
fileInfo)
Mod CommandFields Command
-> Mod CommandFields Command -> Mod CommandFields Command
forall a. Semigroup a => a -> a -> a
<> String -> ParserInfo Command -> Mod CommandFields Command
forall a. String -> ParserInfo a -> Mod CommandFields a
command String
"hiedb" (Parser Command -> InfoMod Command -> ParserInfo Command
forall a. Parser a -> InfoMod a -> ParserInfo a
info (Options -> Command -> Command
Db (Options -> Command -> Command)
-> Parser Options -> Parser (Command -> Command)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Bool -> Parser Options
HieDb.optParser String
"" Bool
True Parser (Command -> Command) -> Parser Command -> Parser Command
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Command
HieDb.cmdParser) InfoMod Command
forall {a}. InfoMod a
hieInfo)
Mod CommandFields Command
-> Mod CommandFields Command -> Mod CommandFields Command
forall a. Semigroup a => a -> a -> a
<> String -> ParserInfo Command -> Mod CommandFields Command
forall a. String -> ParserInfo a -> Mod CommandFields a
command String
"lsp" (Parser Command -> InfoMod Command -> ParserInfo Command
forall a. Parser a -> InfoMod a -> ParserInfo a
info (Command -> Parser Command
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Command
LSP) InfoMod Command
forall {a}. InfoMod a
lspInfo)
Mod CommandFields Command
-> Mod CommandFields Command -> Mod CommandFields Command
forall a. Semigroup a => a -> a -> a
<> Mod CommandFields Command
pluginCommands
)
where
fileCmd :: Parser [String]
fileCmd = Parser String -> Parser [String]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (ReadM String -> Mod ArgumentFields String -> Parser String
forall a. ReadM a -> Mod ArgumentFields a -> Parser a
argument ReadM String
forall s. IsString s => ReadM s
str (String -> Mod ArgumentFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"FILES/DIRS..."))
lspInfo :: InfoMod a
lspInfo = InfoMod a
forall {a}. InfoMod a
fullDesc InfoMod a -> InfoMod a -> InfoMod a
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod a
forall a. String -> InfoMod a
progDesc String
"Start talking to an LSP client"
fileInfo :: InfoMod a
fileInfo = InfoMod a
forall {a}. InfoMod a
fullDesc InfoMod a -> InfoMod a -> InfoMod a
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod a
forall a. String -> InfoMod a
progDesc String
"Used as a test bed to check your IDE will work"
hieInfo :: InfoMod a
hieInfo = InfoMod a
forall {a}. InfoMod a
fullDesc InfoMod a -> InfoMod a -> InfoMod a
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod a
forall a. String -> InfoMod a
progDesc String
"Query .hie files"
pluginCommands :: Mod CommandFields Command
pluginCommands = [Mod CommandFields Command] -> Mod CommandFields Command
forall a. Monoid a => [a] -> a
mconcat
[ String -> ParserInfo Command -> Mod CommandFields Command
forall a. String -> ParserInfo a -> Mod CommandFields a
command (Text -> String
T.unpack Text
pId) (IdeCommand IdeState -> Command
Custom (IdeCommand IdeState -> Command)
-> ParserInfo (IdeCommand IdeState) -> ParserInfo Command
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserInfo (IdeCommand IdeState)
p)
| PluginDescriptor{$sel:pluginCli:PluginDescriptor :: forall ideState.
PluginDescriptor ideState
-> Maybe (ParserInfo (IdeCommand ideState))
pluginCli = Just ParserInfo (IdeCommand IdeState)
p, $sel:pluginId:PluginDescriptor :: forall ideState. PluginDescriptor ideState -> PluginId
pluginId = PluginId Text
pId} <- IdePlugins IdeState -> [PluginDescriptor IdeState]
forall ideState. IdePlugins ideState -> [PluginDescriptor ideState]
ipMap IdePlugins IdeState
plugins
]
data Arguments = Arguments
{ Arguments -> String
argsProjectRoot :: FilePath
, Arguments -> Command
argCommand :: Command
, Arguments -> Rules ()
argsRules :: Rules ()
, Arguments -> IdePlugins IdeState
argsHlsPlugins :: IdePlugins IdeState
, Arguments -> Plugin Config
argsGhcidePlugin :: Plugin Config
, Arguments -> SessionLoadingOptions
argsSessionLoadingOptions :: SessionLoadingOptions
, Arguments -> Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions :: Config -> Action IdeGhcSession -> IdeOptions
, Arguments -> Options
argsLspOptions :: LSP.Options
, Arguments -> Config
argsDefaultHlsConfig :: Config
, Arguments -> String -> IO String
argsGetHieDbLoc :: FilePath -> IO FilePath
, Arguments -> IO (Debouncer NormalizedUri)
argsDebouncer :: IO (Debouncer NormalizedUri)
, Arguments -> IO Handle
argsHandleIn :: IO Handle
, Arguments -> IO Handle
argsHandleOut :: IO Handle
, Arguments -> Maybe Natural
argsThreads :: Maybe Natural
, Arguments -> IO Monitoring
argsMonitoring :: IO Monitoring
, Arguments -> Bool
argsDisableKick :: Bool
}
defaultArguments :: Recorder (WithPriority Log) -> FilePath -> IdePlugins IdeState -> Arguments
defaultArguments :: Recorder (WithPriority Log)
-> String -> IdePlugins IdeState -> Arguments
defaultArguments Recorder (WithPriority Log)
recorder String
projectRoot IdePlugins IdeState
plugins = Arguments
{ argsProjectRoot :: String
argsProjectRoot = String
projectRoot
, argCommand :: Command
argCommand = Command
LSP
, argsRules :: Rules ()
argsRules = Recorder (WithPriority Log) -> RulesConfig -> Rules ()
mainRule ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogRules Recorder (WithPriority Log)
recorder) RulesConfig
forall a. Default a => a
def
, argsGhcidePlugin :: Plugin Config
argsGhcidePlugin = Plugin Config
forall a. Monoid a => a
mempty
, argsHlsPlugins :: IdePlugins IdeState
argsHlsPlugins = [PluginDescriptor IdeState] -> IdePlugins IdeState
forall ideState. [PluginDescriptor ideState] -> IdePlugins ideState
pluginDescToIdePlugins (Recorder (WithPriority Log) -> [PluginDescriptor IdeState]
GhcIde.descriptors ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogGhcIde Recorder (WithPriority Log)
recorder)) IdePlugins IdeState -> IdePlugins IdeState -> IdePlugins IdeState
forall a. Semigroup a => a -> a -> a
<> IdePlugins IdeState
plugins
, argsSessionLoadingOptions :: SessionLoadingOptions
argsSessionLoadingOptions = SessionLoadingOptions
forall a. Default a => a
def
, argsIdeOptions :: Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions = \Config
config Action IdeGhcSession
ghcSession -> (Action IdeGhcSession -> IdeOptions
defaultIdeOptions Action IdeGhcSession
ghcSession)
{ optCheckProject = pure $ checkProject config
, optCheckParents = pure $ checkParents config
}
, argsLspOptions :: Options
argsLspOptions = Options
forall a. Default a => a
def
{ LSP.optCompletionTriggerCharacters = Just "."
, LSP.optProgressStartDelay = 1_000_000
, LSP.optProgressUpdateDelay = 1_00_000
}
, argsDefaultHlsConfig :: Config
argsDefaultHlsConfig = Config
forall a. Default a => a
def
, argsGetHieDbLoc :: String -> IO String
argsGetHieDbLoc = String -> IO String
getHieDbLoc
, argsDebouncer :: IO (Debouncer NormalizedUri)
argsDebouncer = IO (Debouncer NormalizedUri)
forall k. (Eq k, Hashable k) => IO (Debouncer k)
newAsyncDebouncer
, argsThreads :: Maybe Natural
argsThreads = Maybe Natural
forall a. Maybe a
Nothing
, argsHandleIn :: IO Handle
argsHandleIn = Handle -> IO Handle
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Handle
stdin
, argsHandleOut :: IO Handle
argsHandleOut = do
Handle
newStdout <- Handle -> IO Handle
hDuplicate Handle
stdout
Handle
stderr Handle -> Handle -> IO ()
`hDuplicateTo'` Handle
stdout
Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdout BufferMode
NoBuffering
String -> IO ()
putStr String
" " IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout
Handle -> IO Handle
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
newStdout
, argsMonitoring :: IO Monitoring
argsMonitoring = IO Monitoring
OpenTelemetry.monitoring
, argsDisableKick :: Bool
argsDisableKick = Bool
False
}
testing :: Recorder (WithPriority Log) -> FilePath -> IdePlugins IdeState -> Arguments
testing :: Recorder (WithPriority Log)
-> String -> IdePlugins IdeState -> Arguments
testing Recorder (WithPriority Log)
recorder String
projectRoot IdePlugins IdeState
plugins =
let
arguments :: Arguments
arguments@Arguments{ IdePlugins IdeState
argsHlsPlugins :: Arguments -> IdePlugins IdeState
argsHlsPlugins :: IdePlugins IdeState
argsHlsPlugins, Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions :: Arguments -> Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions :: Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions, Options
argsLspOptions :: Arguments -> Options
argsLspOptions :: Options
argsLspOptions } =
Recorder (WithPriority Log)
-> String -> IdePlugins IdeState -> Arguments
defaultArguments Recorder (WithPriority Log)
recorder String
projectRoot IdePlugins IdeState
plugins
hlsPlugins :: IdePlugins IdeState
hlsPlugins = [PluginDescriptor IdeState] -> IdePlugins IdeState
forall ideState. [PluginDescriptor ideState] -> IdePlugins ideState
pluginDescToIdePlugins ([PluginDescriptor IdeState] -> IdePlugins IdeState)
-> [PluginDescriptor IdeState] -> IdePlugins IdeState
forall a b. (a -> b) -> a -> b
$
IdePlugins IdeState -> [PluginDescriptor IdeState]
forall ideState. IdePlugins ideState -> [PluginDescriptor ideState]
idePluginsToPluginDesc IdePlugins IdeState
argsHlsPlugins
[PluginDescriptor IdeState]
-> [PluginDescriptor IdeState] -> [PluginDescriptor IdeState]
forall a. [a] -> [a] -> [a]
++ [PluginId -> PluginDescriptor IdeState
forall state. PluginId -> PluginDescriptor state
Test.blockCommandDescriptor PluginId
"block-command", PluginDescriptor IdeState
Test.plugin]
ideOptions :: Config -> Action IdeGhcSession -> IdeOptions
ideOptions Config
config Action IdeGhcSession
sessionLoader =
let
defOptions :: IdeOptions
defOptions = Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions Config
config Action IdeGhcSession
sessionLoader
in
IdeOptions
defOptions{ optTesting = IdeTesting True }
lspOptions :: Options
lspOptions = Options
argsLspOptions { LSP.optProgressStartDelay = 0, LSP.optProgressUpdateDelay = 0 }
in
Arguments
arguments
{ argsHlsPlugins = hlsPlugins
, argsIdeOptions = ideOptions
, argsLspOptions = lspOptions
}
defaultMain :: Recorder (WithPriority Log) -> Arguments -> IO ()
defaultMain :: Recorder (WithPriority Log) -> Arguments -> IO ()
defaultMain Recorder (WithPriority Log)
recorder Arguments{Bool
String
Maybe Natural
IO Handle
IO (Debouncer NormalizedUri)
IO Monitoring
Rules ()
Config
IdePlugins IdeState
Options
SessionLoadingOptions
Plugin Config
Command
String -> IO String
Config -> Action IdeGhcSession -> IdeOptions
argsProjectRoot :: Arguments -> String
argCommand :: Arguments -> Command
argsRules :: Arguments -> Rules ()
argsHlsPlugins :: Arguments -> IdePlugins IdeState
argsGhcidePlugin :: Arguments -> Plugin Config
argsSessionLoadingOptions :: Arguments -> SessionLoadingOptions
argsIdeOptions :: Arguments -> Config -> Action IdeGhcSession -> IdeOptions
argsLspOptions :: Arguments -> Options
argsDefaultHlsConfig :: Arguments -> Config
argsGetHieDbLoc :: Arguments -> String -> IO String
argsDebouncer :: Arguments -> IO (Debouncer NormalizedUri)
argsHandleIn :: Arguments -> IO Handle
argsHandleOut :: Arguments -> IO Handle
argsThreads :: Arguments -> Maybe Natural
argsMonitoring :: Arguments -> IO Monitoring
argsDisableKick :: Arguments -> Bool
argsProjectRoot :: String
argCommand :: Command
argsRules :: Rules ()
argsHlsPlugins :: IdePlugins IdeState
argsGhcidePlugin :: Plugin Config
argsSessionLoadingOptions :: SessionLoadingOptions
argsIdeOptions :: Config -> Action IdeGhcSession -> IdeOptions
argsLspOptions :: Options
argsDefaultHlsConfig :: Config
argsGetHieDbLoc :: String -> IO String
argsDebouncer :: IO (Debouncer NormalizedUri)
argsHandleIn :: IO Handle
argsHandleOut :: IO Handle
argsThreads :: Maybe Natural
argsMonitoring :: IO Monitoring
argsDisableKick :: Bool
..} = Recorder (WithPriority Log) -> IO () -> IO ()
forall r. Recorder (WithPriority Log) -> IO r -> IO r
withHeapStats ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogHeapStats Recorder (WithPriority Log)
recorder) IO ()
fun
where
fun :: IO ()
fun = do
TextEncoding -> IO ()
setLocaleEncoding TextEncoding
utf8
Text
pid <- String -> Text
T.pack (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> Text) -> IO Int -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Int
getProcessID
Handle -> BufferMode -> IO ()
hSetBuffering Handle
stderr BufferMode
LineBuffering
let hlsPlugin :: Plugin Config
hlsPlugin = Recorder (WithPriority Log) -> IdePlugins IdeState -> Plugin Config
asGhcIdePlugin ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogPluginHLS Recorder (WithPriority Log)
recorder) IdePlugins IdeState
argsHlsPlugins
hlsCommands :: [Text]
hlsCommands = Text -> IdePlugins IdeState -> [Text]
forall ideState. Text -> IdePlugins ideState -> [Text]
allLspCmdIds' Text
pid IdePlugins IdeState
argsHlsPlugins
plugins :: Plugin Config
plugins = Plugin Config
hlsPlugin Plugin Config -> Plugin Config -> Plugin Config
forall a. Semigroup a => a -> a -> a
<> Plugin Config
argsGhcidePlugin
options :: Options
options = Options
argsLspOptions { LSP.optExecuteCommandCommands = LSP.optExecuteCommandCommands argsLspOptions <> Just hlsCommands }
argsParseConfig :: Config -> Value -> Either Text Config
argsParseConfig = IdePlugins IdeState -> Config -> Value -> Either Text Config
forall s. IdePlugins s -> Config -> Value -> Either Text Config
getConfigFromNotification IdePlugins IdeState
argsHlsPlugins
rules :: Rules ()
rules = do
Rules ()
argsRules
Bool -> Rules () -> Rules ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
argsDisableKick (Rules () -> Rules ()) -> Rules () -> Rules ()
forall a b. (a -> b) -> a -> b
$ Action () -> Rules ()
forall a. Action a -> Rules ()
action Action ()
kick
Plugin Config -> Rules ()
forall c. Plugin c -> Rules ()
pluginRules Plugin Config
plugins
Debouncer NormalizedUri
debouncer <- IO (Debouncer NormalizedUri)
argsDebouncer
Handle
inH <- IO Handle
argsHandleIn
Handle
outH <- IO Handle
argsHandleOut
Int
numProcessors <- IO Int
getNumProcessors
let numCapabilities :: Int
numCapabilities = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int -> (Natural -> Int) -> Maybe Natural -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Int
numProcessors Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Maybe Natural
argsThreads
case Command
argCommand of
Command
LSP -> Int -> IO () -> IO ()
forall a. Int -> IO a -> IO a
withNumCapabilities Int
numCapabilities (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
IO Seconds
ioT <- IO (IO Seconds)
offsetTime
Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Info (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ [PluginId] -> Log
LogLspStart (PluginDescriptor IdeState -> PluginId
forall ideState. PluginDescriptor ideState -> PluginId
pluginId (PluginDescriptor IdeState -> PluginId)
-> [PluginDescriptor IdeState] -> [PluginId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IdePlugins IdeState -> [PluginDescriptor IdeState]
forall ideState. IdePlugins ideState -> [PluginDescriptor ideState]
ipMap IdePlugins IdeState
argsHlsPlugins)
MVar IdeState
ideStateVar <- IO (MVar IdeState)
forall a. IO (MVar a)
newEmptyMVar
let getIdeState :: LSP.LanguageContextEnv Config -> FilePath -> WithHieDb -> Shake.ThreadQueue -> IO IdeState
getIdeState :: LanguageContextEnv Config
-> String -> WithHieDb -> ThreadQueue -> IO IdeState
getIdeState LanguageContextEnv Config
env String
rootPath WithHieDb
withHieDb ThreadQueue
threadQueue = do
Seconds
t <- IO Seconds
ioT
Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Info (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ Seconds -> Log
LogLspStartDuration Seconds
t
Maybe LibDir
_mlibdir <-
Recorder (WithPriority Log)
-> String -> SessionLoadingOptions -> IO (Maybe LibDir)
setInitialDynFlags ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogSession Recorder (WithPriority Log)
recorder) String
rootPath SessionLoadingOptions
argsSessionLoadingOptions
IO (Maybe LibDir)
-> (SomeException -> IO (Maybe LibDir)) -> IO (Maybe LibDir)
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> (SomeException -> m a) -> m a
`catchAny` (\SomeException
e -> Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Error (SomeException -> Log
LogSetInitialDynFlagsException SomeException
e) IO () -> IO (Maybe LibDir) -> IO (Maybe LibDir)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe LibDir -> IO (Maybe LibDir)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe LibDir
forall a. Maybe a
Nothing)
Action IdeGhcSession
sessionLoader <- Recorder (WithPriority Log)
-> SessionLoadingOptions
-> String
-> TQueue (IO ())
-> IO (Action IdeGhcSession)
loadSessionWithOptions ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogSession Recorder (WithPriority Log)
recorder) SessionLoadingOptions
argsSessionLoadingOptions String
rootPath (ThreadQueue -> TQueue (IO ())
tLoaderQueue ThreadQueue
threadQueue)
Config
config <- LanguageContextEnv Config -> LspT Config IO Config -> IO Config
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv Config
env LspT Config IO Config
forall config (m :: * -> *). MonadLsp config m => m config
LSP.getConfig
let def_options :: IdeOptions
def_options = Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions Config
config Action IdeGhcSession
sessionLoader
Bool
runSubset <- (IdeOptions -> Bool
optRunSubset IdeOptions
def_options &&) (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LanguageContextEnv Config -> LspT Config IO Bool -> IO Bool
forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv Config
env LspT Config IO Bool
isWatchSupported
Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> Log
LogShouldRunSubset Bool
runSubset
let ideOptions :: IdeOptions
ideOptions = IdeOptions
def_options
{ optReportProgress = clientSupportsProgress caps
, optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins
, optRunSubset = runSubset
}
caps :: ClientCapabilities
caps = LanguageContextEnv Config -> ClientCapabilities
forall config. LanguageContextEnv config -> ClientCapabilities
LSP.resClientCapabilities LanguageContextEnv Config
env
Monitoring
monitoring <- IO Monitoring
argsMonitoring
IdeState
ide <- Recorder (WithPriority Log)
-> Config
-> IdePlugins IdeState
-> Rules ()
-> Maybe (LanguageContextEnv Config)
-> Debouncer NormalizedUri
-> IdeOptions
-> WithHieDb
-> ThreadQueue
-> Monitoring
-> String
-> IO IdeState
initialise
((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogService Recorder (WithPriority Log)
recorder)
Config
argsDefaultHlsConfig
IdePlugins IdeState
argsHlsPlugins
Rules ()
rules
(LanguageContextEnv Config -> Maybe (LanguageContextEnv Config)
forall a. a -> Maybe a
Just LanguageContextEnv Config
env)
Debouncer NormalizedUri
debouncer
IdeOptions
ideOptions
(HieDb -> IO a) -> IO a
WithHieDb
withHieDb
ThreadQueue
threadQueue
Monitoring
monitoring
String
rootPath
MVar IdeState -> IdeState -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar IdeState
ideStateVar IdeState
ide
IdeState -> IO IdeState
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure IdeState
ide
let setup :: MVar ()
-> IO
(LanguageContextEnv Config
-> TRequestMessage 'Method_Initialize
-> IO (Either err (LanguageContextEnv Config, IdeState)),
Handlers (ServerM Config),
(LanguageContextEnv Config, IdeState) -> ServerM Config <~> IO)
setup = Recorder (WithPriority Log)
-> String
-> (String -> IO String)
-> Handlers (ServerM Config)
-> (LanguageContextEnv Config
-> String -> WithHieDb -> ThreadQueue -> IO IdeState)
-> MVar ()
-> IO
(LanguageContextEnv Config
-> TRequestMessage 'Method_Initialize
-> IO (Either err (LanguageContextEnv Config, IdeState)),
Handlers (ServerM Config),
(LanguageContextEnv Config, IdeState) -> ServerM Config <~> IO)
forall config err.
Recorder (WithPriority Log)
-> String
-> (String -> IO String)
-> Handlers (ServerM config)
-> (LanguageContextEnv config
-> String -> WithHieDb -> ThreadQueue -> IO IdeState)
-> MVar ()
-> IO
(LanguageContextEnv config
-> TRequestMessage 'Method_Initialize
-> IO (Either err (LanguageContextEnv config, IdeState)),
Handlers (ServerM config),
(LanguageContextEnv config, IdeState) -> ServerM config <~> IO)
setupLSP ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogLanguageServer Recorder (WithPriority Log)
recorder) String
argsProjectRoot String -> IO String
argsGetHieDbLoc (Plugin Config -> Handlers (ServerM Config)
forall c. Plugin c -> Handlers (ServerM c)
pluginHandlers Plugin Config
plugins) LanguageContextEnv Config
-> String -> WithHieDb -> ThreadQueue -> IO IdeState
getIdeState
onConfigChange :: p -> m ()
onConfigChange p
cfg = do
let cfgObj :: Value
cfgObj = p -> Value
forall a. ToJSON a => a -> Value
J.toJSON p
cfg
Maybe IdeState
mide <- IO (Maybe IdeState) -> m (Maybe IdeState)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe IdeState) -> m (Maybe IdeState))
-> IO (Maybe IdeState) -> m (Maybe IdeState)
forall a b. (a -> b) -> a -> b
$ MVar IdeState -> IO (Maybe IdeState)
forall a. MVar a -> IO (Maybe a)
tryReadMVar MVar IdeState
ideStateVar
case Maybe IdeState
mide of
Maybe IdeState
Nothing -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just IdeState
ide -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
let msg :: Text
msg = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ p -> String
forall a. Show a => a -> String
show p
cfg
VFSModified -> IdeState -> String -> IO [Key] -> IO ()
setSomethingModified VFSModified
Shake.VFSUnmodified IdeState
ide String
"config change" (IO [Key] -> IO ()) -> IO [Key] -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Log
LogConfigurationChange Text
msg
IdeState -> (Maybe Value -> Maybe Value) -> IO ()
modifyClientSettings IdeState
ide (Maybe Value -> Maybe Value -> Maybe Value
forall a b. a -> b -> a
const (Maybe Value -> Maybe Value -> Maybe Value)
-> Maybe Value -> Maybe Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ Value -> Maybe Value
forall a. a -> Maybe a
Just Value
cfgObj)
[Key] -> IO [Key]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [GetClientSettings -> Key
forall k. (Show k, Typeable k, Eq k, Hashable k) => k -> Key
toNoFileKey GetClientSettings
Rules.GetClientSettings]
Recorder (WithPriority Log)
-> Options
-> Handle
-> Handle
-> Config
-> (Config -> Value -> Either Text Config)
-> (Config -> ServerM Config ())
-> (MVar ()
-> IO
(LanguageContextEnv Config
-> TRequestMessage 'Method_Initialize
-> IO
(Either
(TResponseError 'Method_Initialize)
(LanguageContextEnv Config, IdeState)),
Handlers (ServerM Config),
(LanguageContextEnv Config, IdeState) -> ServerM Config <~> IO))
-> IO ()
forall config a (m :: * -> * -> *).
Show config =>
Recorder (WithPriority Log)
-> Options
-> Handle
-> Handle
-> config
-> (config -> Value -> Either Text config)
-> (config -> m config ())
-> (MVar ()
-> IO
(LanguageContextEnv config
-> TRequestMessage 'Method_Initialize
-> IO
(Either
(TResponseError 'Method_Initialize)
(LanguageContextEnv config, a)),
Handlers (m config),
(LanguageContextEnv config, a) -> m config <~> IO))
-> IO ()
runLanguageServer ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogLanguageServer Recorder (WithPriority Log)
recorder) Options
options Handle
inH Handle
outH Config
argsDefaultHlsConfig Config -> Value -> Either Text Config
argsParseConfig Config -> ServerM Config ()
forall {m :: * -> *} {p}.
(MonadIO m, ToJSON p, Show p) =>
p -> m ()
onConfigChange MVar ()
-> IO
(LanguageContextEnv Config
-> TRequestMessage 'Method_Initialize
-> IO
(Either
(TResponseError 'Method_Initialize)
(LanguageContextEnv Config, IdeState)),
Handlers (ServerM Config),
(LanguageContextEnv Config, IdeState) -> ServerM Config <~> IO)
forall {err}.
MVar ()
-> IO
(LanguageContextEnv Config
-> TRequestMessage 'Method_Initialize
-> IO (Either err (LanguageContextEnv Config, IdeState)),
Handlers (ServerM Config),
(LanguageContextEnv Config, IdeState) -> ServerM Config <~> IO)
setup
IO ()
dumpSTMStats
Check [String]
argFiles -> do
let dir :: String
dir = String
argsProjectRoot
String
dbLoc <- String -> IO String
getHieDbLoc String
dir
Recorder (WithPriority Log)
-> String -> (WithHieDb -> ThreadQueue -> IO ()) -> IO ()
runWithWorkerThreads ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogSession Recorder (WithPriority Log)
recorder) String
dbLoc ((WithHieDb -> ThreadQueue -> IO ()) -> IO ())
-> (WithHieDb -> ThreadQueue -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \WithHieDb
hiedb ThreadQueue
threadQueue -> do
Handle -> TextEncoding -> IO ()
hSetEncoding Handle
stdout TextEncoding
utf8
Handle -> TextEncoding -> IO ()
hSetEncoding Handle
stderr TextEncoding
utf8
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"ghcide setup tester in " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
dir String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"."
String -> IO ()
putStrLn String
"Report bugs at https://github.com/haskell/haskell-language-server/issues"
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"\nStep 1/4: Finding files to test in " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
dir
[String]
files <- [String] -> IO [String]
expandFiles ([String]
argFiles [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"." | [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
argFiles])
[String]
absoluteFiles <- [String] -> [String]
forall a. Ord a => [a] -> [a]
nubOrd ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO String) -> [String] -> IO [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM String -> IO String
IO.canonicalizePath [String]
files
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Found " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
absoluteFiles) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" files"
String -> IO ()
putStrLn String
"\nStep 2/4: Looking for hie.yaml files that control setup"
[Maybe String]
cradles <- (String -> IO (Maybe String)) -> [String] -> IO [Maybe String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM String -> IO (Maybe String)
findCradle [String]
absoluteFiles
let ucradles :: [Maybe String]
ucradles = [Maybe String] -> [Maybe String]
forall a. Ord a => [a] -> [a]
nubOrd [Maybe String]
cradles
let n :: Int
n = [Maybe String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Maybe String]
ucradles
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Found " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" cradle" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
's' | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1]
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
" (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ([Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes [Maybe String]
ucradles) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
String -> IO ()
putStrLn String
"\nStep 3/4: Initializing the IDE"
Action IdeGhcSession
sessionLoader <- Recorder (WithPriority Log)
-> SessionLoadingOptions
-> String
-> TQueue (IO ())
-> IO (Action IdeGhcSession)
loadSessionWithOptions ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogSession Recorder (WithPriority Log)
recorder) SessionLoadingOptions
argsSessionLoadingOptions String
dir (ThreadQueue -> TQueue (IO ())
tLoaderQueue ThreadQueue
threadQueue)
let def_options :: IdeOptions
def_options = Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions Config
argsDefaultHlsConfig Action IdeGhcSession
sessionLoader
ideOptions :: IdeOptions
ideOptions = IdeOptions
def_options
{ optCheckParents = pure NeverCheck
, optCheckProject = pure False
, optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins
}
IdeState
ide <- Recorder (WithPriority Log)
-> Config
-> IdePlugins IdeState
-> Rules ()
-> Maybe (LanguageContextEnv Config)
-> Debouncer NormalizedUri
-> IdeOptions
-> WithHieDb
-> ThreadQueue
-> Monitoring
-> String
-> IO IdeState
initialise ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogService Recorder (WithPriority Log)
recorder) Config
argsDefaultHlsConfig IdePlugins IdeState
argsHlsPlugins Rules ()
rules Maybe (LanguageContextEnv Config)
forall a. Maybe a
Nothing Debouncer NormalizedUri
debouncer IdeOptions
ideOptions (HieDb -> IO a) -> IO a
WithHieDb
hiedb ThreadQueue
threadQueue Monitoring
forall a. Monoid a => a
mempty String
dir
Recorder (WithPriority Log) -> IdeState -> IO ()
shakeSessionInit ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) IdeState
ide
ShakeExtras -> IdeConfiguration -> IO ()
registerIdeConfiguration (IdeState -> ShakeExtras
shakeExtras IdeState
ide) (IdeConfiguration -> IO ()) -> IdeConfiguration -> IO ()
forall a b. (a -> b) -> a -> b
$ HashSet NormalizedUri -> Hashed (Maybe Value) -> IdeConfiguration
IdeConfiguration HashSet NormalizedUri
forall a. Monoid a => a
mempty (Maybe Value -> Hashed (Maybe Value)
forall a. Hashable a => a -> Hashed a
hashed Maybe Value
forall a. Maybe a
Nothing)
String -> IO ()
putStrLn String
"\nStep 4/4: Type checking the files"
IdeState
-> HashMap NormalizedFilePath FileOfInterestStatus -> IO ()
setFilesOfInterest IdeState
ide (HashMap NormalizedFilePath FileOfInterestStatus -> IO ())
-> HashMap NormalizedFilePath FileOfInterestStatus -> IO ()
forall a b. (a -> b) -> a -> b
$ [(NormalizedFilePath, FileOfInterestStatus)]
-> HashMap NormalizedFilePath FileOfInterestStatus
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList ([(NormalizedFilePath, FileOfInterestStatus)]
-> HashMap NormalizedFilePath FileOfInterestStatus)
-> [(NormalizedFilePath, FileOfInterestStatus)]
-> HashMap NormalizedFilePath FileOfInterestStatus
forall a b. (a -> b) -> a -> b
$ (String -> (NormalizedFilePath, FileOfInterestStatus))
-> [String] -> [(NormalizedFilePath, FileOfInterestStatus)]
forall a b. (a -> b) -> [a] -> [b]
map ((,FileOfInterestStatus
OnDisk) (NormalizedFilePath -> (NormalizedFilePath, FileOfInterestStatus))
-> (String -> NormalizedFilePath)
-> String
-> (NormalizedFilePath, FileOfInterestStatus)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> NormalizedFilePath
toNormalizedFilePath') [String]
absoluteFiles
[Maybe TcModuleResult]
results <- String
-> IdeState
-> Action [Maybe TcModuleResult]
-> IO [Maybe TcModuleResult]
forall a. String -> IdeState -> Action a -> IO a
runAction String
"User TypeCheck" IdeState
ide (Action [Maybe TcModuleResult] -> IO [Maybe TcModuleResult])
-> Action [Maybe TcModuleResult] -> IO [Maybe TcModuleResult]
forall a b. (a -> b) -> a -> b
$ TypeCheck -> [NormalizedFilePath] -> Action [Maybe TcModuleResult]
forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> Action (f (Maybe v))
uses TypeCheck
TypeCheck ((String -> NormalizedFilePath) -> [String] -> [NormalizedFilePath]
forall a b. (a -> b) -> [a] -> [b]
map String -> NormalizedFilePath
toNormalizedFilePath' [String]
absoluteFiles)
[Maybe HieAstResult]
_results <- String
-> IdeState
-> Action [Maybe HieAstResult]
-> IO [Maybe HieAstResult]
forall a. String -> IdeState -> Action a -> IO a
runAction String
"GetHie" IdeState
ide (Action [Maybe HieAstResult] -> IO [Maybe HieAstResult])
-> Action [Maybe HieAstResult] -> IO [Maybe HieAstResult]
forall a b. (a -> b) -> a -> b
$ GetHieAst -> [NormalizedFilePath] -> Action [Maybe HieAstResult]
forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> Action (f (Maybe v))
uses GetHieAst
GetHieAst ((String -> NormalizedFilePath) -> [String] -> [NormalizedFilePath]
forall a b. (a -> b) -> [a] -> [b]
map String -> NormalizedFilePath
toNormalizedFilePath' [String]
absoluteFiles)
[Maybe ModGuts]
_results <- String -> IdeState -> Action [Maybe ModGuts] -> IO [Maybe ModGuts]
forall a. String -> IdeState -> Action a -> IO a
runAction String
"GenerateCore" IdeState
ide (Action [Maybe ModGuts] -> IO [Maybe ModGuts])
-> Action [Maybe ModGuts] -> IO [Maybe ModGuts]
forall a b. (a -> b) -> a -> b
$ GenerateCore -> [NormalizedFilePath] -> Action [Maybe ModGuts]
forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> Action (f (Maybe v))
uses GenerateCore
GenerateCore ((String -> NormalizedFilePath) -> [String] -> [NormalizedFilePath]
forall a b. (a -> b) -> [a] -> [b]
map String -> NormalizedFilePath
toNormalizedFilePath' [String]
absoluteFiles)
let ([(Bool, String)]
worked, [(Bool, String)]
failed) = ((Bool, String) -> Bool)
-> [(Bool, String)] -> ([(Bool, String)], [(Bool, String)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Bool, String) -> Bool
forall a b. (a, b) -> a
fst ([(Bool, String)] -> ([(Bool, String)], [(Bool, String)]))
-> [(Bool, String)] -> ([(Bool, String)], [(Bool, String)])
forall a b. (a -> b) -> a -> b
$ [Bool] -> [String] -> [(Bool, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Maybe TcModuleResult -> Bool) -> [Maybe TcModuleResult] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map Maybe TcModuleResult -> Bool
forall a. Maybe a -> Bool
isJust [Maybe TcModuleResult]
results) [String]
absoluteFiles
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([(Bool, String)]
failed [(Bool, String)] -> [(Bool, String)] -> Bool
forall a. Eq a => a -> a -> Bool
/= []) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String
"Files that failed:" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ((Bool, String) -> String) -> [(Bool, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> ShowS
forall a. [a] -> [a] -> [a]
(++) String
" * " ShowS -> ((Bool, String) -> String) -> (Bool, String) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, String) -> String
forall a b. (a, b) -> b
snd) [(Bool, String)]
failed
let nfiles :: t a -> String
nfiles t a
xs = let n' :: Int
n' = t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
xs in if Int
n' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then String
"1 file" else Int -> String
forall a. Show a => a -> String
show Int
n' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" files"
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"\nCompleted (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(Bool, String)] -> String
forall {t :: * -> *} {a}. Foldable t => t a -> String
nfiles [(Bool, String)]
worked String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" worked, " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(Bool, String)] -> String
forall {t :: * -> *} {a}. Foldable t => t a -> String
nfiles [(Bool, String)]
failed String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" failed)"
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(Bool, String)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Bool, String)]
failed) (ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO ()) -> ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure ([(Bool, String)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Bool, String)]
failed))
Db Options
opts Command
cmd -> do
let root :: String
root = String
argsProjectRoot
String
dbLoc <- String -> IO String
getHieDbLoc String
root
Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Using hiedb at: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
dbLoc
Maybe LibDir
mlibdir <- Recorder (WithPriority Log)
-> String -> SessionLoadingOptions -> IO (Maybe LibDir)
setInitialDynFlags ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogSession Recorder (WithPriority Log)
recorder) String
root SessionLoadingOptions
forall a. Default a => a
def
StdGen
rng <- IO StdGen
forall (m :: * -> *). MonadIO m => m StdGen
newStdGen
case Maybe LibDir
mlibdir of
Maybe LibDir
Nothing -> ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO ()) -> ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
1
Just LibDir
libdir -> Recorder (WithPriority Log) -> StdGen -> IO () -> IO ()
forall (m :: * -> *) g a.
(MonadIO m, MonadCatch m, RandomGen g) =>
Recorder (WithPriority Log) -> g -> m a -> m a
retryOnSqliteBusy ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogSession Recorder (WithPriority Log)
recorder) StdGen
rng (LibDir -> Options -> Command -> IO ()
HieDb.runCommand LibDir
libdir Options
opts{HieDb.database = dbLoc} Command
cmd)
Custom (IdeCommand IdeState -> IO ()
c) -> do
let root :: String
root = String
argsProjectRoot
String
dbLoc <- String -> IO String
getHieDbLoc String
root
Recorder (WithPriority Log)
-> String -> (WithHieDb -> ThreadQueue -> IO ()) -> IO ()
runWithWorkerThreads ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogSession Recorder (WithPriority Log)
recorder) String
dbLoc ((WithHieDb -> ThreadQueue -> IO ()) -> IO ())
-> (WithHieDb -> ThreadQueue -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \WithHieDb
hiedb ThreadQueue
threadQueue -> do
Action IdeGhcSession
sessionLoader <- Recorder (WithPriority Log)
-> SessionLoadingOptions
-> String
-> TQueue (IO ())
-> IO (Action IdeGhcSession)
loadSessionWithOptions ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogSession Recorder (WithPriority Log)
recorder) SessionLoadingOptions
argsSessionLoadingOptions String
"." (ThreadQueue -> TQueue (IO ())
tLoaderQueue ThreadQueue
threadQueue)
let def_options :: IdeOptions
def_options = Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions Config
argsDefaultHlsConfig Action IdeGhcSession
sessionLoader
ideOptions :: IdeOptions
ideOptions = IdeOptions
def_options
{ optCheckParents = pure NeverCheck
, optCheckProject = pure False
, optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins
}
IdeState
ide <- Recorder (WithPriority Log)
-> Config
-> IdePlugins IdeState
-> Rules ()
-> Maybe (LanguageContextEnv Config)
-> Debouncer NormalizedUri
-> IdeOptions
-> WithHieDb
-> ThreadQueue
-> Monitoring
-> String
-> IO IdeState
initialise ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogService Recorder (WithPriority Log)
recorder) Config
argsDefaultHlsConfig IdePlugins IdeState
argsHlsPlugins Rules ()
rules Maybe (LanguageContextEnv Config)
forall a. Maybe a
Nothing Debouncer NormalizedUri
debouncer IdeOptions
ideOptions (HieDb -> IO a) -> IO a
WithHieDb
hiedb ThreadQueue
threadQueue Monitoring
forall a. Monoid a => a
mempty String
root
Recorder (WithPriority Log) -> IdeState -> IO ()
shakeSessionInit ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogShake Recorder (WithPriority Log)
recorder) IdeState
ide
ShakeExtras -> IdeConfiguration -> IO ()
registerIdeConfiguration (IdeState -> ShakeExtras
shakeExtras IdeState
ide) (IdeConfiguration -> IO ()) -> IdeConfiguration -> IO ()
forall a b. (a -> b) -> a -> b
$ HashSet NormalizedUri -> Hashed (Maybe Value) -> IdeConfiguration
IdeConfiguration HashSet NormalizedUri
forall a. Monoid a => a
mempty (Maybe Value -> Hashed (Maybe Value)
forall a. Hashable a => a -> Hashed a
hashed Maybe Value
forall a. Maybe a
Nothing)
IdeState -> IO ()
c IdeState
ide
expandFiles :: [FilePath] -> IO [FilePath]
expandFiles :: [String] -> IO [String]
expandFiles = (String -> IO [String]) -> [String] -> IO [String]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM ((String -> IO [String]) -> [String] -> IO [String])
-> (String -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ \String
x -> do
Bool
b <- String -> IO Bool
IO.doesFileExist String
x
if Bool
b
then [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [String
x]
else do
let recurse :: String -> Bool
recurse String
"." = Bool
True
recurse String
y | String
"." String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` ShowS
takeFileName String
y = Bool
False
recurse String
y = ShowS
takeFileName String
y String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String
"dist", String
"dist-newstyle"]
[String]
files <- (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (\String
y -> ShowS
takeExtension String
y String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
".hs", String
".lhs"]) ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO Bool) -> String -> IO [String]
IO.listFilesInside (Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> (String -> Bool) -> String -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
recurse) String
x
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
files) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Couldn't find any .hs/.lhs files inside directory: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
x
[String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
files