{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE RankNTypes #-}
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.Foldable                            (traverse_)
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, emptyFilePath,
                                                           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),
                                                           IndexQueue,
                                                           shakeSessionInit,
                                                           uses)
import qualified Development.IDE.Core.Shake               as Shake
import           Development.IDE.Graph                    (action)
import           Development.IDE.LSP.LanguageServer       (runLanguageServer,
                                                           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.EKG           as EKG
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,
                                                           runWithDb,
                                                           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, toKey)
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                               (Logger,
                                                           Pretty (pretty),
                                                           Priority (Info),
                                                           Recorder,
                                                           WithPriority,
                                                           cmapWithPrio,
                                                           logDebug, 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
  | 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Log] -> ShowS
$cshowList :: [Log] -> ShowS
show :: Log -> String
$cshow :: Log -> String
showsPrec :: Int -> Log -> ShowS
$cshowsPrec :: Int -> Log -> ShowS
Show

instance Pretty Log where
  pretty :: forall ann. Log -> Doc ann
pretty = \case
    LogHeapStats Log
msg -> forall a ann. Pretty a => a -> Doc ann
pretty Log
msg
    LogLspStart [PluginId]
pluginIds ->
      forall ann. Int -> Doc ann -> Doc ann
nest Int
2 forall a b. (a -> b) -> a -> b
$ 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:" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (coerce :: forall a b. Coercible a b => a -> b
coerce @_ @[T.Text] [PluginId]
pluginIds)
        ]
    LogLspStartDuration Seconds
duration ->
      Doc ann
"Started LSP server in" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (Seconds -> String
showDuration Seconds
duration)
    LogShouldRunSubset Bool
shouldRunSubset ->
      Doc ann
"shouldRunSubset:" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Bool
shouldRunSubset
    LogSetInitialDynFlagsException SomeException
e ->
      Doc ann
"setInitialDynFlags:" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (forall e. Exception e => e -> String
displayException SomeException
e)
    LogService Log
msg -> forall a ann. Pretty a => a -> Doc ann
pretty Log
msg
    LogShake Log
msg -> forall a ann. Pretty a => a -> Doc ann
pretty Log
msg
    LogGhcIde Log
msg -> forall a ann. Pretty a => a -> Doc ann
pretty Log
msg
    LogLanguageServer Log
msg -> forall a ann. Pretty a => a -> Doc ann
pretty Log
msg
    LogSession Log
msg -> forall a ann. Pretty a => a -> Doc ann
pretty Log
msg
    LogPluginHLS Log
msg -> forall a ann. Pretty a => a -> Doc ann
pretty Log
msg
    LogRules Log
msg -> forall a ann. Pretty a => a -> Doc ann
pretty Log
msg

data Command
    = Check [FilePath]  -- ^ Typecheck some paths and print diagnostics. Exit code is the number of failures
    | Db {Command -> Options
hieOptions ::  HieDb.Options, Command -> Command
hieCommand :: HieDb.Command}
     -- ^ Run a command in the hiedb
    | LSP   -- ^ Run the LSP server
    | Custom {Command -> IdeCommand IdeState
ideCommand :: IdeCommand IdeState} -- ^ User defined
    deriving Int -> Command -> ShowS
[Command] -> ShowS
Command -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Command] -> ShowS
$cshowList :: [Command] -> ShowS
show :: Command -> String
$cshow :: Command -> String
showsPrec :: Int -> Command -> ShowS
$cshowsPrec :: Int -> Command -> ShowS
Show

-- TODO move these to hiedb
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 =
    forall a. Mod CommandFields a -> Parser a
hsubparser(forall a. String -> ParserInfo a -> Mod CommandFields a
command String
"typecheck" (forall a. Parser a -> InfoMod a -> ParserInfo a
info ([String] -> Command
Check forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [String]
fileCmd) forall {a}. InfoMod a
fileInfo)
            forall a. Semigroup a => a -> a -> a
<> forall a. String -> ParserInfo a -> Mod CommandFields a
command String
"hiedb" (forall a. Parser a -> InfoMod a -> ParserInfo a
info (Options -> Command -> Command
Db forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Bool -> Parser Options
HieDb.optParser String
"" Bool
True forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Command
HieDb.cmdParser) forall {a}. InfoMod a
hieInfo)
            forall a. Semigroup a => a -> a -> a
<> forall a. String -> ParserInfo a -> Mod CommandFields a
command String
"lsp" (forall a. Parser a -> InfoMod a -> ParserInfo a
info (forall (f :: * -> *) a. Applicative f => a -> f a
pure Command
LSP) forall {a}. InfoMod a
lspInfo)
            forall a. Semigroup a => a -> a -> a
<> Mod CommandFields Command
pluginCommands
            )
  where
    fileCmd :: Parser [String]
fileCmd = forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (forall a. ReadM a -> Mod ArgumentFields a -> Parser a
argument forall s. IsString s => ReadM s
str (forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"FILES/DIRS..."))
    lspInfo :: InfoMod a
lspInfo = forall {a}. InfoMod a
fullDesc forall a. Semigroup a => a -> a -> a
<> forall a. String -> InfoMod a
progDesc String
"Start talking to an LSP client"
    fileInfo :: InfoMod a
fileInfo = forall {a}. InfoMod a
fullDesc forall a. Semigroup a => a -> a -> a
<> forall a. String -> InfoMod a
progDesc String
"Used as a test bed to check your IDE will work"
    hieInfo :: InfoMod a
hieInfo = forall {a}. InfoMod a
fullDesc forall a. Semigroup a => a -> a -> a
<> forall a. String -> InfoMod a
progDesc String
"Query .hie files"

    pluginCommands :: Mod CommandFields Command
pluginCommands = forall a. Monoid a => [a] -> a
mconcat
        [ forall a. String -> ParserInfo a -> Mod CommandFields a
command (Text -> String
T.unpack Text
pId) (IdeCommand IdeState -> Command
Custom 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} <- forall ideState. IdePlugins ideState -> [PluginDescriptor ideState]
ipMap IdePlugins IdeState
plugins
        ]


data Arguments = Arguments
    { Arguments -> Maybe String
argsProjectRoot           :: Maybe FilePath
    , Arguments -> Command
argCommand                :: Command
    , Arguments -> IO Logger
argsLogger                :: IO Logger
    , Arguments -> Rules ()
argsRules                 :: Rules ()
    , Arguments -> IdePlugins IdeState
argsHlsPlugins            :: IdePlugins IdeState
    , Arguments -> Plugin Config
argsGhcidePlugin          :: Plugin Config  -- ^ Deprecated
    , 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 -- ^ Map project roots to the location of the hiedb for the project
    , Arguments -> IO (Debouncer NormalizedUri)
argsDebouncer             :: IO (Debouncer NormalizedUri) -- ^ Debouncer used for diagnostics
    , Arguments -> IO Handle
argsHandleIn              :: IO Handle
    , Arguments -> IO Handle
argsHandleOut             :: IO Handle
    , Arguments -> Maybe Natural
argsThreads               :: Maybe Natural
    , Arguments -> IO Monitoring
argsMonitoring            :: IO Monitoring
    }

defaultArguments :: Recorder (WithPriority Log) -> Logger -> IdePlugins IdeState -> Arguments
defaultArguments :: Recorder (WithPriority Log)
-> Logger -> IdePlugins IdeState -> Arguments
defaultArguments Recorder (WithPriority Log)
recorder Logger
logger IdePlugins IdeState
plugins = Arguments
        { argsProjectRoot :: Maybe String
argsProjectRoot = forall a. Maybe a
Nothing
        , argCommand :: Command
argCommand = Command
LSP
        , argsLogger :: IO Logger
argsLogger = forall (f :: * -> *) a. Applicative f => a -> f a
pure Logger
logger
        , argsRules :: Rules ()
argsRules = Recorder (WithPriority Log) -> RulesConfig -> Rules ()
mainRule (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogRules Recorder (WithPriority Log)
recorder) forall a. Default a => a
def forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Action a -> Rules ()
action Action ()
kick
        , argsGhcidePlugin :: Plugin Config
argsGhcidePlugin = forall a. Monoid a => a
mempty
        , argsHlsPlugins :: IdePlugins IdeState
argsHlsPlugins = forall ideState. [PluginDescriptor ideState] -> IdePlugins ideState
pluginDescToIdePlugins (Recorder (WithPriority Log) -> [PluginDescriptor IdeState]
GhcIde.descriptors (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogGhcIde Recorder (WithPriority Log)
recorder)) forall a. Semigroup a => a -> a -> a
<> IdePlugins IdeState
plugins
        , argsSessionLoadingOptions :: SessionLoadingOptions
argsSessionLoadingOptions = 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 :: IO Bool
optCheckProject = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Config -> Bool
checkProject Config
config
            , optCheckParents :: IO CheckParents
optCheckParents = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Config -> CheckParents
checkParents Config
config
            }
        , argsLspOptions :: Options
argsLspOptions = forall a. Default a => a
def {optCompletionTriggerCharacters :: Maybe String
LSP.optCompletionTriggerCharacters = forall a. a -> Maybe a
Just String
"."}
        , argsDefaultHlsConfig :: Config
argsDefaultHlsConfig = forall a. Default a => a
def
        , argsGetHieDbLoc :: String -> IO String
argsGetHieDbLoc = String -> IO String
getHieDbLoc
        , argsDebouncer :: IO (Debouncer NormalizedUri)
argsDebouncer = forall k. (Eq k, Hashable k) => IO (Debouncer k)
newAsyncDebouncer
        , argsThreads :: Maybe Natural
argsThreads = forall a. Maybe a
Nothing
        , argsHandleIn :: IO Handle
argsHandleIn = forall (f :: * -> *) a. Applicative f => a -> f a
pure Handle
stdin
        , argsHandleOut :: IO Handle
argsHandleOut = do
                -- Move stdout to another file descriptor and duplicate stderr
                -- to stdout. This guards against stray prints from corrupting the JSON-RPC
                -- message stream.
                Handle
newStdout <- Handle -> IO Handle
hDuplicate Handle
stdout
                Handle
stderr Handle -> Handle -> IO ()
`hDuplicateTo'` Handle
stdout
                Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdout BufferMode
NoBuffering

                -- Print out a single space to assert that the above redirection works.
                -- This is interleaved with the logger, hence we just print a space here in
                -- order not to mess up the output too much. Verified that this breaks
                -- the language server tests without the redirection.
                String -> IO ()
putStr String
" " forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout
                forall (m :: * -> *) a. Monad m => a -> m a
return Handle
newStdout
        , argsMonitoring :: IO Monitoring
argsMonitoring = IO Monitoring
OpenTelemetry.monitoring forall a. Semigroup a => a -> a -> a
<> Logger -> Int -> IO Monitoring
EKG.monitoring Logger
logger Int
8999
        }


testing :: Recorder (WithPriority Log) -> Logger -> IdePlugins IdeState -> Arguments
testing :: Recorder (WithPriority Log)
-> Logger -> IdePlugins IdeState -> Arguments
testing Recorder (WithPriority Log)
recorder Logger
logger IdePlugins IdeState
plugins =
  let
    arguments :: Arguments
arguments@Arguments{ IdePlugins IdeState
argsHlsPlugins :: IdePlugins IdeState
argsHlsPlugins :: Arguments -> IdePlugins IdeState
argsHlsPlugins, Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions :: Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions :: Arguments -> Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions } =
        Recorder (WithPriority Log)
-> Logger -> IdePlugins IdeState -> Arguments
defaultArguments Recorder (WithPriority Log)
recorder Logger
logger IdePlugins IdeState
plugins
    hlsPlugins :: IdePlugins IdeState
hlsPlugins = forall ideState. [PluginDescriptor ideState] -> IdePlugins ideState
pluginDescToIdePlugins forall a b. (a -> b) -> a -> b
$
      forall ideState. IdePlugins ideState -> [PluginDescriptor ideState]
idePluginsToPluginDesc IdePlugins IdeState
argsHlsPlugins
      forall a. [a] -> [a] -> [a]
++ [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
optTesting = Bool -> IdeTesting
IdeTesting Bool
True }
  in
    Arguments
arguments
      { argsHlsPlugins :: IdePlugins IdeState
argsHlsPlugins = IdePlugins IdeState
hlsPlugins
      , argsIdeOptions :: Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions = Config -> Action IdeGhcSession -> IdeOptions
ideOptions
      }

defaultMain :: Recorder (WithPriority Log) -> Arguments -> IO ()
defaultMain :: Recorder (WithPriority Log) -> Arguments -> IO ()
defaultMain Recorder (WithPriority Log)
recorder Arguments{Maybe Natural
Maybe String
IO Handle
IO Logger
IO (Debouncer NormalizedUri)
IO Monitoring
Rules ()
IdePlugins IdeState
Config
Options
SessionLoadingOptions
Plugin Config
Command
String -> IO String
Config -> Action IdeGhcSession -> IdeOptions
argsMonitoring :: IO Monitoring
argsThreads :: Maybe Natural
argsHandleOut :: IO Handle
argsHandleIn :: IO Handle
argsDebouncer :: IO (Debouncer NormalizedUri)
argsGetHieDbLoc :: String -> IO String
argsDefaultHlsConfig :: Config
argsLspOptions :: Options
argsIdeOptions :: Config -> Action IdeGhcSession -> IdeOptions
argsSessionLoadingOptions :: SessionLoadingOptions
argsGhcidePlugin :: Plugin Config
argsHlsPlugins :: IdePlugins IdeState
argsRules :: Rules ()
argsLogger :: IO Logger
argCommand :: Command
argsProjectRoot :: Maybe String
argsMonitoring :: Arguments -> IO Monitoring
argsThreads :: Arguments -> Maybe Natural
argsHandleOut :: Arguments -> IO Handle
argsHandleIn :: Arguments -> IO Handle
argsDebouncer :: Arguments -> IO (Debouncer NormalizedUri)
argsGetHieDbLoc :: Arguments -> String -> IO String
argsDefaultHlsConfig :: Arguments -> Config
argsLspOptions :: Arguments -> Options
argsIdeOptions :: Arguments -> Config -> Action IdeGhcSession -> IdeOptions
argsSessionLoadingOptions :: Arguments -> SessionLoadingOptions
argsGhcidePlugin :: Arguments -> Plugin Config
argsHlsPlugins :: Arguments -> IdePlugins IdeState
argsRules :: Arguments -> Rules ()
argsLogger :: Arguments -> IO Logger
argCommand :: Arguments -> Command
argsProjectRoot :: Arguments -> Maybe String
..} = forall r. Recorder (WithPriority Log) -> IO r -> IO r
withHeapStats (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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Int
getProcessID
    Logger
logger <- IO Logger
argsLogger
    Handle -> BufferMode -> IO ()
hSetBuffering Handle
stderr BufferMode
LineBuffering

    let hlsPlugin :: Plugin Config
hlsPlugin = Recorder (WithPriority Log) -> IdePlugins IdeState -> Plugin Config
asGhcIdePlugin (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 = forall ideState. Text -> IdePlugins ideState -> [Text]
allLspCmdIds' Text
pid IdePlugins IdeState
argsHlsPlugins
        plugins :: Plugin Config
plugins = Plugin Config
hlsPlugin forall a. Semigroup a => a -> a -> a
<> Plugin Config
argsGhcidePlugin
        options :: Options
options = Options
argsLspOptions { optExecuteCommandCommands :: Maybe [Text]
LSP.optExecuteCommandCommands = Options -> Maybe [Text]
LSP.optExecuteCommandCommands Options
argsLspOptions forall a. Semigroup a => a -> a -> a
<> forall a. a -> Maybe a
Just [Text]
hlsCommands }
        argsParseConfig :: Config -> Value -> Either Text Config
argsParseConfig = forall s. IdePlugins s -> Config -> Value -> Either Text Config
getConfigFromNotification IdePlugins IdeState
argsHlsPlugins
        rules :: Rules ()
rules = Rules ()
argsRules forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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 = forall a. Ord a => a -> a -> a
max Int
1 forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Int
numProcessors forall a. Integral a => a -> a -> a
`div` Int
2) forall a b. (Integral a, Num b) => a -> b
fromIntegral Maybe Natural
argsThreads

    case Command
argCommand of
        Command
LSP -> forall a. Int -> IO a -> IO a
withNumCapabilities Int
numCapabilities forall a b. (a -> b) -> a -> b
$ do
            IO Seconds
ioT <- IO (IO Seconds)
offsetTime
            forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Info forall a b. (a -> b) -> a -> b
$ [PluginId] -> Log
LogLspStart (forall ideState. PluginDescriptor ideState -> PluginId
pluginId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall ideState. IdePlugins ideState -> [PluginDescriptor ideState]
ipMap IdePlugins IdeState
argsHlsPlugins)

            MVar IdeState
ideStateVar <- forall a. IO (MVar a)
newEmptyMVar
            let getIdeState :: LSP.LanguageContextEnv Config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState
                getIdeState :: LanguageContextEnv Config
-> Maybe String -> WithHieDb -> IndexQueue -> IO IdeState
getIdeState LanguageContextEnv Config
env Maybe String
rootPath WithHieDb
withHieDb IndexQueue
hieChan = do
                  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ String -> IO ()
IO.setCurrentDirectory Maybe String
rootPath
                  Seconds
t <- IO Seconds
ioT
                  forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Info forall a b. (a -> b) -> a -> b
$ Seconds -> Log
LogLspStartDuration Seconds
t

                  String
dir <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO String
IO.getCurrentDirectory forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
rootPath

                  -- We want to set the global DynFlags right now, so that we can use
                  -- `unsafeGlobalDynFlags` even before the project is configured
                  Maybe LibDir
_mlibdir <-
                      Recorder (WithPriority Log)
-> String -> SessionLoadingOptions -> IO (Maybe LibDir)
setInitialDynFlags (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogSession Recorder (WithPriority Log)
recorder) String
dir SessionLoadingOptions
argsSessionLoadingOptions
                          -- TODO: should probably catch/log/rethrow at top level instead
                          forall (m :: * -> *) a.
MonadCatch m =>
m a -> (SomeException -> m a) -> m a
`catchAny` (\SomeException
e -> forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Error (SomeException -> Log
LogSetInitialDynFlagsException SomeException
e) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing)

                  Action IdeGhcSession
sessionLoader <- Recorder (WithPriority Log)
-> SessionLoadingOptions -> String -> IO (Action IdeGhcSession)
loadSessionWithOptions (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogSession Recorder (WithPriority Log)
recorder) SessionLoadingOptions
argsSessionLoadingOptions String
dir
                  Config
config <- forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv Config
env 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

                  -- disable runSubset if the client doesn't support watched files
                  Bool
runSubset <- (IdeOptions -> Bool
optRunSubset IdeOptions
def_options Bool -> Bool -> Bool
&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
LSP.runLspT LanguageContextEnv Config
env LspT Config IO Bool
isWatchSupported
                  forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Debug forall a b. (a -> b) -> a -> b
$ Bool -> Log
LogShouldRunSubset Bool
runSubset

                  let ideOptions :: IdeOptions
ideOptions = IdeOptions
def_options
                              { optReportProgress :: IdeReportProgress
optReportProgress = ClientCapabilities -> IdeReportProgress
clientSupportsProgress ClientCapabilities
caps
                              , optModifyDynFlags :: Config -> DynFlagsModifications
optModifyDynFlags = IdeOptions -> Config -> DynFlagsModifications
optModifyDynFlags IdeOptions
def_options forall a. Semigroup a => a -> a -> a
<> forall c. Plugin c -> c -> DynFlagsModifications
pluginModifyDynflags Plugin Config
plugins
                              , optRunSubset :: Bool
optRunSubset = Bool
runSubset
                              }
                      caps :: ClientCapabilities
caps = 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)
-> Logger
-> Debouncer NormalizedUri
-> IdeOptions
-> WithHieDb
-> IndexQueue
-> Monitoring
-> IO IdeState
initialise
                      (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
                      (forall a. a -> Maybe a
Just LanguageContextEnv Config
env)
                      Logger
logger
                      Debouncer NormalizedUri
debouncer
                      IdeOptions
ideOptions
                      WithHieDb
withHieDb
                      IndexQueue
hieChan
                      Monitoring
monitoring
                  forall a. MVar a -> a -> IO ()
putMVar MVar IdeState
ideStateVar IdeState
ide
                  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 = forall config err.
Recorder (WithPriority Log)
-> (String -> IO String)
-> Handlers (ServerM config)
-> (LanguageContextEnv config
    -> Maybe String -> WithHieDb -> IndexQueue -> 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 (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogLanguageServer Recorder (WithPriority Log)
recorder) String -> IO String
argsGetHieDbLoc (forall c. Plugin c -> Handlers (ServerM c)
pluginHandlers Plugin Config
plugins) LanguageContextEnv Config
-> Maybe String -> WithHieDb -> IndexQueue -> IO IdeState
getIdeState
                -- See Note [Client configuration in Rules]
                onConfigChange :: p -> m ()
onConfigChange p
cfg = do
                  -- TODO: this is nuts, we're converting back to JSON just to get a fingerprint
                  let cfgObj :: Value
cfgObj = forall a. ToJSON a => a -> Value
J.toJSON p
cfg
                  Maybe IdeState
mide <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO (Maybe a)
tryReadMVar MVar IdeState
ideStateVar
                  case Maybe IdeState
mide of
                    Maybe IdeState
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                    Just IdeState
ide -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
                        let msg :: Text
msg = String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show p
cfg
                        Logger -> Text -> IO ()
logDebug (IdeState -> Logger
Shake.ideLogger IdeState
ide) forall a b. (a -> b) -> a -> b
$ Text
"Configuration changed: " forall a. Semigroup a => a -> a -> a
<> Text
msg
                        IdeState -> (Maybe Value -> Maybe Value) -> IO ()
modifyClientSettings IdeState
ide (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Value
cfgObj)
                        VFSModified -> IdeState -> [Key] -> String -> IO ()
setSomethingModified VFSModified
Shake.VFSUnmodified IdeState
ide [forall k. ShakeValue k => k -> NormalizedFilePath -> Key
toKey GetClientSettings
Rules.GetClientSettings NormalizedFilePath
emptyFilePath] String
"config change"

            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 ResponseError (LanguageContextEnv config, a)),
          Handlers (m config),
          (LanguageContextEnv config, a) -> m config <~> IO))
-> IO ()
runLanguageServer (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 forall {m :: * -> *} {p}.
(MonadIO m, ToJSON p, Show p) =>
p -> m ()
onConfigChange 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
          String
dir <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO String
IO.getCurrentDirectory forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
argsProjectRoot
          String
dbLoc <- String -> IO String
getHieDbLoc String
dir
          Recorder (WithPriority Log)
-> String -> (WithHieDb -> IndexQueue -> IO ()) -> IO ()
runWithDb (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogSession Recorder (WithPriority Log)
recorder) String
dbLoc forall a b. (a -> b) -> a -> b
$ \WithHieDb
hiedb IndexQueue
hieChan -> do
            -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error
            Handle -> TextEncoding -> IO ()
hSetEncoding Handle
stdout TextEncoding
utf8
            Handle -> TextEncoding -> IO ()
hSetEncoding Handle
stderr TextEncoding
utf8

            String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"ghcide setup tester in " forall a. [a] -> [a] -> [a]
++ String
dir forall a. [a] -> [a] -> [a]
++ String
"."
            String -> IO ()
putStrLn String
"Report bugs at https://github.com/haskell/haskell-language-server/issues"

            String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"\nStep 1/4: Finding files to test in " forall a. [a] -> [a] -> [a]
++ String
dir
            [String]
files <- [String] -> IO [String]
expandFiles ([String]
argFiles forall a. [a] -> [a] -> [a]
++ [String
"." | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
argFiles])
            -- LSP works with absolute file paths, so try and behave similarly
            [String]
absoluteFiles <- forall a. Ord a => [a] -> [a]
nubOrd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO String
IO.canonicalizePath [String]
files
            String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"Found " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
absoluteFiles) 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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO (Maybe String)
findCradle [String]
absoluteFiles
            let ucradles :: [Maybe String]
ucradles = forall a. Ord a => [a] -> [a]
nubOrd [Maybe String]
cradles
            let n :: Int
n = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Maybe String]
ucradles
            String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"Found " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n forall a. [a] -> [a] -> [a]
++ String
" cradle" forall a. [a] -> [a] -> [a]
++ [Char
's' | Int
n forall a. Eq a => a -> a -> Bool
/= Int
1]
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"  (" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
", " (forall a. [Maybe a] -> [a]
catMaybes [Maybe String]
ucradles) forall a. [a] -> [a] -> [a]
++ String
")"
            String -> IO ()
putStrLn String
"\nStep 3/4: Initializing the IDE"
            Action IdeGhcSession
sessionLoader <- Recorder (WithPriority Log)
-> SessionLoadingOptions -> String -> IO (Action IdeGhcSession)
loadSessionWithOptions (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogSession Recorder (WithPriority Log)
recorder) SessionLoadingOptions
argsSessionLoadingOptions String
dir
            let def_options :: IdeOptions
def_options = Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions Config
argsDefaultHlsConfig Action IdeGhcSession
sessionLoader
                ideOptions :: IdeOptions
ideOptions = IdeOptions
def_options
                        { optCheckParents :: IO CheckParents
optCheckParents = forall (f :: * -> *) a. Applicative f => a -> f a
pure CheckParents
NeverCheck
                        , optCheckProject :: IO Bool
optCheckProject = forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
                        , optModifyDynFlags :: Config -> DynFlagsModifications
optModifyDynFlags = IdeOptions -> Config -> DynFlagsModifications
optModifyDynFlags IdeOptions
def_options forall a. Semigroup a => a -> a -> a
<> forall c. Plugin c -> c -> DynFlagsModifications
pluginModifyDynflags Plugin Config
plugins
                        }
            IdeState
ide <- Recorder (WithPriority Log)
-> Config
-> IdePlugins IdeState
-> Rules ()
-> Maybe (LanguageContextEnv Config)
-> Logger
-> Debouncer NormalizedUri
-> IdeOptions
-> WithHieDb
-> IndexQueue
-> Monitoring
-> IO IdeState
initialise (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 forall a. Maybe a
Nothing Logger
logger Debouncer NormalizedUri
debouncer IdeOptions
ideOptions WithHieDb
hiedb IndexQueue
hieChan forall a. Monoid a => a
mempty
            Recorder (WithPriority Log) -> IdeState -> IO ()
shakeSessionInit (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) forall a b. (a -> b) -> a -> b
$ HashSet NormalizedUri -> Hashed (Maybe Value) -> IdeConfiguration
IdeConfiguration forall a. Monoid a => a
mempty (forall a. Hashable a => a -> Hashed a
hashed forall a. Maybe a
Nothing)

            String -> IO ()
putStrLn String
"\nStep 4/4: Type checking the files"
            IdeState
-> HashMap NormalizedFilePath FileOfInterestStatus -> IO ()
setFilesOfInterest IdeState
ide forall a b. (a -> b) -> a -> b
$ forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ((,FileOfInterestStatus
OnDisk) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> NormalizedFilePath
toNormalizedFilePath') [String]
absoluteFiles
            [Maybe TcModuleResult]
results <- forall a. String -> IdeState -> Action a -> IO a
runAction String
"User TypeCheck" IdeState
ide forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> Action (f (Maybe v))
uses TypeCheck
TypeCheck (forall a b. (a -> b) -> [a] -> [b]
map String -> NormalizedFilePath
toNormalizedFilePath' [String]
absoluteFiles)
            [Maybe HieAstResult]
_results <- forall a. String -> IdeState -> Action a -> IO a
runAction String
"GetHie" IdeState
ide forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> Action (f (Maybe v))
uses GetHieAst
GetHieAst (forall a b. (a -> b) -> [a] -> [b]
map String -> NormalizedFilePath
toNormalizedFilePath' [String]
absoluteFiles)
            [Maybe ModGuts]
_results <- forall a. String -> IdeState -> Action a -> IO a
runAction String
"GenerateCore" IdeState
ide forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) k v.
(Traversable f, IdeRule k v) =>
k -> f NormalizedFilePath -> Action (f (Maybe v))
uses GenerateCore
GenerateCore (forall a b. (a -> b) -> [a] -> [b]
map String -> NormalizedFilePath
toNormalizedFilePath' [String]
absoluteFiles)
            let ([(Bool, String)]
worked, [(Bool, String)]
failed) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map forall a. Maybe a -> Bool
isJust [Maybe TcModuleResult]
results) [String]
absoluteFiles
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([(Bool, String)]
failed forall a. Eq a => a -> a -> Bool
/= []) forall a b. (a -> b) -> a -> b
$
                String -> IO ()
putStr forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ String
"Files that failed:" forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (forall a. [a] -> [a] -> [a]
(++) String
" * " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Bool, String)]
failed

            let nfiles :: t a -> String
nfiles t a
xs = let n' :: Int
n' = forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
xs in if Int
n' forall a. Eq a => a -> a -> Bool
== Int
1 then String
"1 file" else forall a. Show a => a -> String
show Int
n' forall a. [a] -> [a] -> [a]
++ String
" files"
            String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"\nCompleted (" forall a. [a] -> [a] -> [a]
++ forall {t :: * -> *} {a}. Foldable t => t a -> String
nfiles [(Bool, String)]
worked forall a. [a] -> [a] -> [a]
++ String
" worked, " forall a. [a] -> [a] -> [a]
++ forall {t :: * -> *} {a}. Foldable t => t a -> String
nfiles [(Bool, String)]
failed forall a. [a] -> [a] -> [a]
++ String
" failed)"

            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Bool, String)]
failed) (forall a. ExitCode -> IO a
exitWith forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Bool, String)]
failed))
        Db Options
opts Command
cmd -> do
            String
root <-  forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO String
IO.getCurrentDirectory forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
argsProjectRoot
            String
dbLoc <- String -> IO String
getHieDbLoc String
root
            Handle -> String -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ String
"Using hiedb at: " forall a. [a] -> [a] -> [a]
++ String
dbLoc
            Maybe LibDir
mlibdir <- Recorder (WithPriority Log)
-> String -> SessionLoadingOptions -> IO (Maybe LibDir)
setInitialDynFlags (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogSession Recorder (WithPriority Log)
recorder) String
root forall a. Default a => a
def
            StdGen
rng <- forall (m :: * -> *). MonadIO m => m StdGen
newStdGen
            case Maybe LibDir
mlibdir of
                Maybe LibDir
Nothing     -> forall a. ExitCode -> IO a
exitWith forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
1
                Just LibDir
libdir -> forall (m :: * -> *) g a.
(MonadIO m, MonadCatch m, RandomGen g) =>
Recorder (WithPriority Log) -> g -> m a -> m a
retryOnSqliteBusy (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{database :: String
HieDb.database = String
dbLoc} Command
cmd)

        Custom (IdeCommand IdeState -> IO ()
c) -> do
          String
root <-  forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO String
IO.getCurrentDirectory forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
argsProjectRoot
          String
dbLoc <- String -> IO String
getHieDbLoc String
root
          Recorder (WithPriority Log)
-> String -> (WithHieDb -> IndexQueue -> IO ()) -> IO ()
runWithDb (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogSession Recorder (WithPriority Log)
recorder) String
dbLoc forall a b. (a -> b) -> a -> b
$ \WithHieDb
hiedb IndexQueue
hieChan -> do
            Action IdeGhcSession
sessionLoader <- Recorder (WithPriority Log)
-> SessionLoadingOptions -> String -> IO (Action IdeGhcSession)
loadSessionWithOptions (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogSession Recorder (WithPriority Log)
recorder) SessionLoadingOptions
argsSessionLoadingOptions String
"."
            let def_options :: IdeOptions
def_options = Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions Config
argsDefaultHlsConfig Action IdeGhcSession
sessionLoader
                ideOptions :: IdeOptions
ideOptions = IdeOptions
def_options
                    { optCheckParents :: IO CheckParents
optCheckParents = forall (f :: * -> *) a. Applicative f => a -> f a
pure CheckParents
NeverCheck
                    , optCheckProject :: IO Bool
optCheckProject = forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
                    , optModifyDynFlags :: Config -> DynFlagsModifications
optModifyDynFlags = IdeOptions -> Config -> DynFlagsModifications
optModifyDynFlags IdeOptions
def_options forall a. Semigroup a => a -> a -> a
<> forall c. Plugin c -> c -> DynFlagsModifications
pluginModifyDynflags Plugin Config
plugins
                    }
            IdeState
ide <- Recorder (WithPriority Log)
-> Config
-> IdePlugins IdeState
-> Rules ()
-> Maybe (LanguageContextEnv Config)
-> Logger
-> Debouncer NormalizedUri
-> IdeOptions
-> WithHieDb
-> IndexQueue
-> Monitoring
-> IO IdeState
initialise (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 forall a. Maybe a
Nothing Logger
logger Debouncer NormalizedUri
debouncer IdeOptions
ideOptions WithHieDb
hiedb IndexQueue
hieChan forall a. Monoid a => a
mempty
            Recorder (WithPriority Log) -> IdeState -> IO ()
shakeSessionInit (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) forall a b. (a -> b) -> a -> b
$ HashSet NormalizedUri -> Hashed (Maybe Value) -> IdeConfiguration
IdeConfiguration forall a. Monoid a => a
mempty (forall a. Hashable a => a -> Hashed a
hashed forall a. Maybe a
Nothing)
            IdeState -> IO ()
c IdeState
ide

expandFiles :: [FilePath] -> IO [FilePath]
expandFiles :: [String] -> IO [String]
expandFiles = forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM forall a b. (a -> b) -> a -> b
$ \String
x -> do
    Bool
b <- String -> IO Bool
IO.doesFileExist String
x
    if Bool
b
        then 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
"." forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` ShowS
takeFileName String
y = Bool
False -- skip .git etc
                recurse String
y = ShowS
takeFileName String
y forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String
"dist", String
"dist-newstyle"] -- cabal directories
            [String]
files <- forall a. (a -> Bool) -> [a] -> [a]
filter (\String
y -> ShowS
takeExtension String
y forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
".hs", String
".lhs"]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO Bool) -> String -> IO [String]
IO.listFilesInside (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
recurse) String
x
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
files) forall a b. (a -> b) -> a -> b
$
                forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Couldn't find any .hs/.lhs files inside directory: " forall a. [a] -> [a] -> [a]
++ String
x
            forall (m :: * -> *) a. Monad m => a -> m a
return [String]
files