{-# LANGUAGE PackageImports #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Development.IDE.Main
(Arguments(..)
,defaultArguments
,Command(..)
,IdeCommand(..)
,isLSP
,commandP
,defaultMain
,testing) where
import           Control.Concurrent.Extra              (newLock, withLock,
                                                        withNumCapabilities)
import           Control.Concurrent.STM.Stats          (atomically,
                                                        dumpSTMStats)
import           Control.Exception.Safe                (Exception (displayException),
                                                        catchAny)
import           Control.Monad.Extra                   (concatMapM, unless,
                                                        when)
import qualified Data.Aeson.Encode.Pretty              as A
import           Data.Default                          (Default (def))
import           Data.Foldable                         (traverse_)
import qualified Data.HashMap.Strict                   as HashMap
import           Data.Hashable                         (hashed)
import           Data.List.Extra                       (intercalate, isPrefixOf,
                                                        nub, nubOrd, partition)
import           Data.Maybe                            (catMaybes, isJust)
import qualified Data.Text                             as T
import qualified Data.Text.IO                          as T
import           Data.Text.Lazy.Encoding               (decodeUtf8)
import qualified Data.Text.Lazy.IO                     as LT
import           Data.Typeable                         (typeOf)
import           Development.IDE                       (Action, GhcVersion (..),
                                                        Priority (Debug), Rules,
                                                        ghcVersion,
                                                        hDuplicateTo')
import           Development.IDE.Core.Debouncer        (Debouncer,
                                                        newAsyncDebouncer)
import           Development.IDE.Core.FileStore        (isWatchSupported,
                                                        makeVFSHandle)
import           Development.IDE.Core.IdeConfiguration (IdeConfiguration (..),
                                                        registerIdeConfiguration)
import           Development.IDE.Core.OfInterest       (FileOfInterestStatus (OnDisk),
                                                        kick,
                                                        setFilesOfInterest)
import           Development.IDE.Core.RuleTypes        (GenerateCore (GenerateCore),
                                                        GetHieAst (GetHieAst),
                                                        GhcSession (GhcSession),
                                                        GhcSessionDeps (GhcSessionDeps),
                                                        TypeCheck (TypeCheck))
import           Development.IDE.Core.Rules            (GhcSessionIO (GhcSessionIO),
                                                        mainRule)
import           Development.IDE.Core.Service          (initialise, runAction)
import           Development.IDE.Core.Shake            (IdeState (shakeExtras),
                                                        ShakeExtras (state),
                                                        shakeSessionInit, uses)
import           Development.IDE.Core.Tracing          (measureMemory)
import           Development.IDE.Graph                 (action)
import           Development.IDE.LSP.LanguageServer    (runLanguageServer)
import           Development.IDE.Main.HeapStats        (withHeapStats)
import           Development.IDE.Plugin                (Plugin (pluginHandlers, pluginModifyDynflags, pluginRules))
import           Development.IDE.Plugin.HLS            (asGhcIdePlugin)
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           Development.IDE.Types.Location        (NormalizedUri,
                                                        toNormalizedFilePath')
import           Development.IDE.Types.Logger          (Logger (Logger),
                                                        Priority (Info),
                                                        logDebug, logInfo)
import           Development.IDE.Types.Options         (IdeGhcSession,
                                                        IdeOptions (optCheckParents, optCheckProject, optReportProgress, optRunSubset),
                                                        IdeTesting (IdeTesting),
                                                        clientSupportsProgress,
                                                        defaultIdeOptions,
                                                        optModifyDynFlags,
                                                        optTesting)
import           Development.IDE.Types.Shake           (fromKeyType)
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.Plugin.Config                     (CheckParents (NeverCheck),
                                                        Config, checkParents,
                                                        checkProject,
                                                        getConfigFromNotification)
import           Ide.Plugin.ConfigUtils                (pluginsToDefaultConfig,
                                                        pluginsToVSCodeExtensionSchema)
import           Ide.PluginUtils                       (allLspCmdIds',
                                                        getProcessID,
                                                        idePluginsToPluginDesc,
                                                        pluginDescToIdePlugins)
import           Ide.Types                             (IdeCommand (IdeCommand),
                                                        IdePlugins,
                                                        PluginDescriptor (PluginDescriptor, pluginCli),
                                                        PluginId (PluginId),
                                                        ipMap)
import qualified Language.LSP.Server                   as LSP
import qualified "list-t" ListT
import           Numeric.Natural                       (Natural)
import           Options.Applicative                   hiding (action)
import qualified StmContainers.Map                     as STM
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                     (offsetTime,
                                                        showDuration)
import           Text.Printf                           (printf)

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
    | PrintExtensionSchema
    | PrintDefaultConfig
    | Custom {Command -> IdeCommand IdeState
ideCommand :: IdeCommand IdeState} -- ^ User defined
    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
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 =
    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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Command
HieDb.cmdParser Parser Command -> Parser (Command -> Command) -> Parser Command
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> Parser (Command -> Command)
forall a. Parser (a -> a)
helper) 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 (f :: * -> *) a. Applicative f => a -> f a
pure Command
LSP Parser Command -> Parser (Command -> Command) -> Parser Command
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> Parser (Command -> Command)
forall a. Parser (a -> a)
helper) InfoMod Command
forall a. InfoMod a
lspInfo)
            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
"vscode-extension-schema" ParserInfo Command
extensionSchemaCommand
            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
"generate-default-config" ParserInfo Command
generateDefaultConfigCommand
            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 (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"
    extensionSchemaCommand :: ParserInfo Command
extensionSchemaCommand =
        Parser Command -> InfoMod Command -> ParserInfo Command
forall a. Parser a -> InfoMod a -> ParserInfo a
info (Command -> Parser Command
forall (f :: * -> *) a. Applicative f => a -> f a
pure Command
PrintExtensionSchema)
             (InfoMod Command
forall a. InfoMod a
fullDesc InfoMod Command -> InfoMod Command -> InfoMod Command
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod Command
forall a. String -> InfoMod a
progDesc String
"Print generic config schema for plugins (used in the package.json of haskell vscode extension)")
    generateDefaultConfigCommand :: ParserInfo Command
generateDefaultConfigCommand =
        Parser Command -> InfoMod Command -> ParserInfo Command
forall a. Parser a -> InfoMod a -> ParserInfo a
info (Command -> Parser Command
forall (f :: * -> *) a. Applicative f => a -> f a
pure Command
PrintDefaultConfig)
             (InfoMod Command
forall a. InfoMod a
fullDesc InfoMod Command -> InfoMod Command -> InfoMod Command
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod Command
forall a. String -> InfoMod a
progDesc String
"Print config supported by the server with default values")

    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)
        | (PluginId Text
pId, PluginDescriptor{pluginCli :: forall ideState.
PluginDescriptor ideState
-> Maybe (ParserInfo (IdeCommand ideState))
pluginCli = Just ParserInfo (IdeCommand IdeState)
p}) <- IdePlugins IdeState -> [(PluginId, PluginDescriptor IdeState)]
forall ideState.
IdePlugins ideState -> [(PluginId, PluginDescriptor ideState)]
ipMap IdePlugins IdeState
plugins
        ]


data Arguments = Arguments
    { Arguments -> Maybe String
argsProjectRoot           :: Maybe FilePath
    , Arguments -> Bool
argsOTMemoryProfiling     :: Bool
    , 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
    }

instance Default Arguments where
    def :: Arguments
def = Priority -> Arguments
defaultArguments Priority
Info

defaultArguments :: Priority -> Arguments
defaultArguments :: Priority -> Arguments
defaultArguments Priority
priority = Arguments :: Maybe String
-> Bool
-> Command
-> IO Logger
-> Rules ()
-> IdePlugins IdeState
-> Plugin Config
-> SessionLoadingOptions
-> (Config -> Action IdeGhcSession -> IdeOptions)
-> Options
-> Config
-> (String -> IO String)
-> IO (Debouncer NormalizedUri)
-> IO Handle
-> IO Handle
-> Maybe Natural
-> Arguments
Arguments
        { argsProjectRoot :: Maybe String
argsProjectRoot = Maybe String
forall a. Maybe a
Nothing
        , argsOTMemoryProfiling :: Bool
argsOTMemoryProfiling = Bool
False
        , argCommand :: Command
argCommand = Command
LSP
        , argsLogger :: IO Logger
argsLogger = Priority -> IO Logger
stderrLogger Priority
priority
        , argsRules :: Rules ()
argsRules = RulesConfig -> Rules ()
mainRule RulesConfig
forall a. Default a => a
def Rules () -> Rules () -> Rules ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Action () -> Rules ()
forall a. Action a -> Rules ()
action Action ()
kick
        , 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 [PluginDescriptor IdeState]
Ghcide.descriptors
        , 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 :: IO Bool
optCheckProject = Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Config -> Bool
checkProject Config
config
            , optCheckParents :: IO CheckParents
optCheckParents = CheckParents -> IO CheckParents
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CheckParents -> IO CheckParents)
-> CheckParents -> IO CheckParents
forall a b. (a -> b) -> a -> b
$ Config -> CheckParents
checkParents Config
config
            }
        , argsLspOptions :: Options
argsLspOptions = Options
forall a. Default a => a
def {completionTriggerCharacters :: Maybe String
LSP.completionTriggerCharacters = String -> Maybe String
forall a. a -> Maybe a
Just String
"."}
        , 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 (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
" " IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout
                Handle -> IO Handle
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
newStdout
        }

testing :: Arguments
testing :: Arguments
testing = (Priority -> Arguments
defaultArguments Priority
Debug) {
    argsHlsPlugins :: IdePlugins IdeState
argsHlsPlugins = [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 (Arguments -> IdePlugins IdeState
argsHlsPlugins Arguments
forall a. Default a => a
def)
        [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],
    argsIdeOptions :: Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions = \Config
config Action IdeGhcSession
sessionLoader ->
            let defOptions :: IdeOptions
defOptions = Arguments -> Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions Arguments
forall a. Default a => a
def Config
config Action IdeGhcSession
sessionLoader
            in IdeOptions
defOptions {
                optTesting :: IdeTesting
optTesting = Bool -> IdeTesting
IdeTesting Bool
True
            }
}

-- | Cheap stderr logger that relies on LineBuffering
stderrLogger :: Priority -> IO Logger
stderrLogger :: Priority -> IO Logger
stderrLogger Priority
logLevel = do
    Lock
lock <- IO Lock
newLock
    Logger -> IO Logger
forall (m :: * -> *) a. Monad m => a -> m a
return (Logger -> IO Logger) -> Logger -> IO Logger
forall a b. (a -> b) -> a -> b
$ (Priority -> Text -> IO ()) -> Logger
Logger ((Priority -> Text -> IO ()) -> Logger)
-> (Priority -> Text -> IO ()) -> Logger
forall a b. (a -> b) -> a -> b
$ \Priority
p Text
m -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Priority
p Priority -> Priority -> Bool
forall a. Ord a => a -> a -> Bool
>= Priority
logLevel) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Lock -> IO () -> IO ()
forall a. Lock -> IO a -> IO a
withLock Lock
lock (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Priority -> String
forall a. Show a => a -> String
show Priority
p) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"] " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
m

defaultMain :: Arguments -> IO ()
defaultMain :: Arguments -> IO ()
defaultMain Arguments{Bool
Maybe Natural
Maybe String
IO Handle
IO (Debouncer NormalizedUri)
IO Logger
Rules ()
IdePlugins IdeState
Config
Options
SessionLoadingOptions
Plugin Config
Command
String -> IO String
Config -> Action IdeGhcSession -> IdeOptions
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
argsOTMemoryProfiling :: Bool
argsProjectRoot :: Maybe String
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
argsOTMemoryProfiling :: Arguments -> Bool
argsProjectRoot :: Arguments -> Maybe String
..} = (Logger -> IO () -> IO ()) -> IO () -> Logger -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Logger -> IO () -> IO ()
forall r. Logger -> IO r -> IO r
withHeapStats IO ()
fun (Logger -> IO ()) -> IO Logger -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Logger
argsLogger
 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
    Logger
logger <- IO Logger
argsLogger
    Handle -> BufferMode -> IO ()
hSetBuffering Handle
stderr BufferMode
LineBuffering

    let hlsPlugin :: Plugin Config
hlsPlugin = IdePlugins IdeState -> Plugin Config
asGhcIdePlugin 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 { executeCommandCommands :: Maybe [Text]
LSP.executeCommandCommands = Options -> Maybe [Text]
LSP.executeCommandCommands Options
argsLspOptions Maybe [Text] -> Maybe [Text] -> Maybe [Text]
forall a. Semigroup a => a -> a -> a
<> [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just [Text]
hlsCommands }
        argsOnConfigChange :: Config -> Value -> Either Text Config
argsOnConfigChange = Config -> Value -> Either Text Config
getConfigFromNotification
        rules :: Rules ()
rules = Rules ()
argsRules Rules () -> Rules () -> Rules ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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

    case Command
argCommand of
        Command
PrintExtensionSchema ->
            Text -> IO ()
LT.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
A.encodePretty (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ IdePlugins IdeState -> Value
forall a. IdePlugins a -> Value
pluginsToVSCodeExtensionSchema IdePlugins IdeState
argsHlsPlugins
        Command
PrintDefaultConfig ->
            Text -> IO ()
LT.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
A.encodePretty (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ IdePlugins IdeState -> Value
forall a. IdePlugins a -> Value
pluginsToDefaultConfig IdePlugins IdeState
argsHlsPlugins
        Command
LSP -> Int -> IO () -> IO ()
forall a. Int -> IO a -> IO a
withNumCapabilities (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) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            IO Seconds
t <- IO (IO Seconds)
offsetTime
            Logger -> Text -> IO ()
logInfo Logger
logger Text
"Starting LSP server..."
            Logger -> Text -> IO ()
logInfo Logger
logger Text
"If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option!"
            Options
-> Handle
-> Handle
-> (String -> IO String)
-> Config
-> (Config -> Value -> Either Text Config)
-> Handlers (ServerM Config)
-> (LanguageContextEnv Config
    -> VFSHandle
    -> Maybe String
    -> WithHieDb
    -> IndexQueue
    -> IO IdeState)
-> IO ()
forall config.
Show config =>
Options
-> Handle
-> Handle
-> (String -> IO String)
-> config
-> (config -> Value -> Either Text config)
-> Handlers (ServerM config)
-> (LanguageContextEnv config
    -> VFSHandle
    -> Maybe String
    -> WithHieDb
    -> IndexQueue
    -> IO IdeState)
-> IO ()
runLanguageServer Options
options Handle
inH Handle
outH String -> IO String
argsGetHieDbLoc Config
argsDefaultHlsConfig Config -> Value -> Either Text Config
argsOnConfigChange (Plugin Config -> Handlers (ServerM Config)
forall c. Plugin c -> Handlers (ServerM c)
pluginHandlers Plugin Config
plugins) ((LanguageContextEnv Config
  -> VFSHandle
  -> Maybe String
  -> WithHieDb
  -> IndexQueue
  -> IO IdeState)
 -> IO ())
-> (LanguageContextEnv Config
    -> VFSHandle
    -> Maybe String
    -> WithHieDb
    -> IndexQueue
    -> IO IdeState)
-> IO ()
forall a b. (a -> b) -> a -> b
$ \LanguageContextEnv Config
env VFSHandle
vfs Maybe String
rootPath WithHieDb
withHieDb IndexQueue
hieChan -> do
                (String -> IO ()) -> Maybe String -> IO ()
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
t
                Logger -> Text -> IO ()
logInfo Logger
logger (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Started LSP server in " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Seconds -> String
showDuration Seconds
t

                String
dir <- IO String -> (String -> IO String) -> Maybe String -> IO String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO String
IO.getCurrentDirectory String -> IO String
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 <-
                    Logger -> String -> SessionLoadingOptions -> IO (Maybe LibDir)
setInitialDynFlags Logger
logger String
dir SessionLoadingOptions
argsSessionLoadingOptions
                        IO (Maybe LibDir)
-> (SomeException -> IO (Maybe LibDir)) -> IO (Maybe LibDir)
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (SomeException -> m a) -> m a
`catchAny` (\SomeException
e -> (Logger -> Text -> IO ()
logDebug Logger
logger (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"setInitialDynFlags: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e) IO () -> IO (Maybe LibDir) -> IO (Maybe LibDir)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe LibDir -> IO (Maybe LibDir)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe LibDir
forall a. Maybe a
Nothing)


                Action IdeGhcSession
sessionLoader <- SessionLoadingOptions -> String -> IO (Action IdeGhcSession)
loadSessionWithOptions SessionLoadingOptions
argsSessionLoadingOptions String
dir
                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

                -- disable runSubset if the client doesn't support watched files
                Bool
runSubset <- (IdeOptions -> Bool
optRunSubset IdeOptions
def_options Bool -> Bool -> Bool
&&) (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
                Logger -> Text -> IO ()
logDebug Logger
logger (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"runSubset: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Bool -> String
forall a. Show a => a -> String
show Bool
runSubset

                let options :: IdeOptions
options = IdeOptions
def_options
                            { optReportProgress :: IdeReportProgress
optReportProgress = ClientCapabilities -> IdeReportProgress
clientSupportsProgress ClientCapabilities
caps
                            , optModifyDynFlags :: Config -> DynFlagsModifications
optModifyDynFlags = IdeOptions -> Config -> DynFlagsModifications
optModifyDynFlags IdeOptions
def_options (Config -> DynFlagsModifications)
-> (Config -> DynFlagsModifications)
-> Config
-> DynFlagsModifications
forall a. Semigroup a => a -> a -> a
<> Plugin Config -> Config -> DynFlagsModifications
forall c. Plugin c -> c -> DynFlagsModifications
pluginModifyDynflags Plugin Config
plugins
                            , optRunSubset :: Bool
optRunSubset = Bool
runSubset
                            }
                    caps :: ClientCapabilities
caps = LanguageContextEnv Config -> ClientCapabilities
forall config. LanguageContextEnv config -> ClientCapabilities
LSP.resClientCapabilities LanguageContextEnv Config
env
                -- FIXME: Remove this after GHC 9 gets fully supported
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GhcVersion
ghcVersion GhcVersion -> GhcVersion -> Bool
forall a. Eq a => a -> a -> Bool
== GhcVersion
GHC90) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                    Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                        String
"Currently, HLS supports GHC 9 only partially. "
                        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"See [issue #297](https://github.com/haskell/haskell-language-server/issues/297) for more detail."
                Config
-> Rules ()
-> Maybe (LanguageContextEnv Config)
-> Logger
-> Debouncer NormalizedUri
-> IdeOptions
-> VFSHandle
-> WithHieDb
-> IndexQueue
-> IO IdeState
initialise
                    Config
argsDefaultHlsConfig
                    Rules ()
rules
                    (LanguageContextEnv Config -> Maybe (LanguageContextEnv Config)
forall a. a -> Maybe a
Just LanguageContextEnv Config
env)
                    Logger
logger
                    Debouncer NormalizedUri
debouncer
                    IdeOptions
options
                    VFSHandle
vfs
                    WithHieDb
withHieDb
                    IndexQueue
hieChan
            IO ()
dumpSTMStats
        Check [String]
argFiles -> do
          String
dir <- IO String -> (String -> IO String) -> Maybe String -> IO String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO String
IO.getCurrentDirectory String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
argsProjectRoot
          String
dbLoc <- String -> IO String
getHieDbLoc String
dir
          Logger -> String -> (WithHieDb -> IndexQueue -> IO ()) -> IO ()
runWithDb Logger
logger String
dbLoc ((WithHieDb -> IndexQueue -> IO ()) -> IO ())
-> (WithHieDb -> IndexQueue -> IO ()) -> IO ()
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 (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 (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
argFiles])
            -- LSP works with absolute file paths, so try and behave similarly
            [String]
files <- [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)
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 (t :: * -> *) a. Foldable t => t a -> Int
length [String]
files) 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)
mapM String -> IO (Maybe String)
findCradle [String]
files
            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 (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"
            VFSHandle
vfs <- IO VFSHandle
makeVFSHandle
            Action IdeGhcSession
sessionLoader <- SessionLoadingOptions -> String -> IO (Action IdeGhcSession)
loadSessionWithOptions SessionLoadingOptions
argsSessionLoadingOptions String
dir
            let def_options :: IdeOptions
def_options = Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions Config
argsDefaultHlsConfig Action IdeGhcSession
sessionLoader
                options :: IdeOptions
options = IdeOptions
def_options
                        { optCheckParents :: IO CheckParents
optCheckParents = CheckParents -> IO CheckParents
forall (f :: * -> *) a. Applicative f => a -> f a
pure CheckParents
NeverCheck
                        , optCheckProject :: IO Bool
optCheckProject = Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
                        , optModifyDynFlags :: Config -> DynFlagsModifications
optModifyDynFlags = IdeOptions -> Config -> DynFlagsModifications
optModifyDynFlags IdeOptions
def_options (Config -> DynFlagsModifications)
-> (Config -> DynFlagsModifications)
-> Config
-> DynFlagsModifications
forall a. Semigroup a => a -> a -> a
<> Plugin Config -> Config -> DynFlagsModifications
forall c. Plugin c -> c -> DynFlagsModifications
pluginModifyDynflags Plugin Config
plugins
                        }
            IdeState
ide <- Config
-> Rules ()
-> Maybe (LanguageContextEnv Config)
-> Logger
-> Debouncer NormalizedUri
-> IdeOptions
-> VFSHandle
-> WithHieDb
-> IndexQueue
-> IO IdeState
initialise Config
argsDefaultHlsConfig Rules ()
rules Maybe (LanguageContextEnv Config)
forall a. Maybe a
Nothing Logger
logger Debouncer NormalizedUri
debouncer IdeOptions
options VFSHandle
vfs WithHieDb
hiedb IndexQueue
hieChan
            IdeState -> IO ()
shakeSessionInit 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]
files
            [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 k v.
IdeRule k v =>
k -> [NormalizedFilePath] -> Action [Maybe v]
uses TypeCheck
TypeCheck ((String -> NormalizedFilePath) -> [String] -> [NormalizedFilePath]
forall a b. (a -> b) -> [a] -> [b]
map String -> NormalizedFilePath
toNormalizedFilePath' [String]
files)
            [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 k v.
IdeRule k v =>
k -> [NormalizedFilePath] -> Action [Maybe v]
uses GetHieAst
GetHieAst ((String -> NormalizedFilePath) -> [String] -> [NormalizedFilePath]
forall a b. (a -> b) -> [a] -> [b]
map String -> NormalizedFilePath
toNormalizedFilePath' [String]
files)
            [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 k v.
IdeRule k v =>
k -> [NormalizedFilePath] -> Action [Maybe v]
uses GenerateCore
GenerateCore ((String -> NormalizedFilePath) -> [String] -> [NormalizedFilePath]
forall a b. (a -> b) -> [a] -> [b]
map String -> NormalizedFilePath
toNormalizedFilePath' [String]
files)
            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]
files
            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 (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 ()
when Bool
argsOTMemoryProfiling (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                let values :: Values
values = ShakeExtras -> Values
state (ShakeExtras -> Values) -> ShakeExtras -> Values
forall a b. (a -> b) -> a -> b
$ IdeState -> ShakeExtras
shakeExtras IdeState
ide
                let consoleObserver :: Maybe a -> m (Int -> t)
consoleObserver Maybe a
Nothing = (Int -> t) -> m (Int -> t)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int -> t) -> m (Int -> t)) -> (Int -> t) -> m (Int -> t)
forall a b. (a -> b) -> a -> b
$ \Int
size -> String -> Seconds -> t
forall r. PrintfType r => String -> r
printf String
"Total: %.2fMB\n" (Int -> Seconds
forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @Double Int
size Seconds -> Seconds -> Seconds
forall a. Fractional a => a -> a -> a
/ Seconds
1e6)
                    consoleObserver (Just a
k) = (Int -> t) -> m (Int -> t)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int -> t) -> m (Int -> t)) -> (Int -> t) -> m (Int -> t)
forall a b. (a -> b) -> a -> b
$ \Int
size -> String -> String -> Seconds -> t
forall r. PrintfType r => String -> r
printf String
"  - %s: %.2fKB\n" (a -> String
forall a. Show a => a -> String
show a
k) (Int -> Seconds
forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @Double Int
size Seconds -> Seconds -> Seconds
forall a. Fractional a => a -> a -> a
/ Seconds
1e3)

                [(Key, ValueWithDiagnostics)]
stateContents <- STM [(Key, ValueWithDiagnostics)]
-> IO [(Key, ValueWithDiagnostics)]
forall a. STM a -> IO a
atomically (STM [(Key, ValueWithDiagnostics)]
 -> IO [(Key, ValueWithDiagnostics)])
-> STM [(Key, ValueWithDiagnostics)]
-> IO [(Key, ValueWithDiagnostics)]
forall a b. (a -> b) -> a -> b
$ ListT STM (Key, ValueWithDiagnostics)
-> STM [(Key, ValueWithDiagnostics)]
forall (m :: * -> *) a. Monad m => ListT m a -> m [a]
ListT.toList (ListT STM (Key, ValueWithDiagnostics)
 -> STM [(Key, ValueWithDiagnostics)])
-> ListT STM (Key, ValueWithDiagnostics)
-> STM [(Key, ValueWithDiagnostics)]
forall a b. (a -> b) -> a -> b
$ Values -> ListT STM (Key, ValueWithDiagnostics)
forall key value. Map key value -> ListT STM (key, value)
STM.listT Values
values
                String -> Int -> IO ()
forall r. PrintfType r => String -> r
printf String
"# Shake value store contents(%d):\n" ([(Key, ValueWithDiagnostics)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Key, ValueWithDiagnostics)]
stateContents)
                let keys :: [TypeRep]
keys =
                        [TypeRep] -> [TypeRep]
forall a. Eq a => [a] -> [a]
nub ([TypeRep] -> [TypeRep]) -> [TypeRep] -> [TypeRep]
forall a b. (a -> b) -> a -> b
$
                            GhcSession -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf GhcSession
GhcSession TypeRep -> [TypeRep] -> [TypeRep]
forall a. a -> [a] -> [a]
:
                            GhcSessionDeps -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf GhcSessionDeps
GhcSessionDeps TypeRep -> [TypeRep] -> [TypeRep]
forall a. a -> [a] -> [a]
:
                            [TypeRep
kty | (Key -> Maybe (TypeRep, NormalizedFilePath)
fromKeyType -> Just (TypeRep
kty,NormalizedFilePath
_), ValueWithDiagnostics
_) <- [(Key, ValueWithDiagnostics)]
stateContents, TypeRep
kty TypeRep -> TypeRep -> Bool
forall a. Eq a => a -> a -> Bool
/= GhcSessionIO -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf GhcSessionIO
GhcSessionIO] [TypeRep] -> [TypeRep] -> [TypeRep]
forall a. [a] -> [a] -> [a]
++
                            [GhcSessionIO -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf GhcSessionIO
GhcSessionIO]
                Logger
-> [[TypeRep]]
-> (Maybe String -> IO (Int -> IO ()))
-> Values
-> IO ()
measureMemory Logger
logger [[TypeRep]
keys] Maybe String -> IO (Int -> IO ())
forall (m :: * -> *) t a.
(Monad m, PrintfType t, Show a) =>
Maybe a -> m (Int -> t)
consoleObserver Values
values

            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(Bool, String)] -> 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 (t :: * -> *) a. Foldable t => t a -> Int
length [(Bool, String)]
failed))
        Db Options
opts Command
cmd -> do
            String
root <-  IO String -> (String -> IO String) -> Maybe String -> IO String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO String
IO.getCurrentDirectory String -> IO String
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 (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 <- Logger -> String -> SessionLoadingOptions -> IO (Maybe LibDir)
setInitialDynFlags Logger
logger 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 -> Logger -> StdGen -> IO () -> IO ()
forall (m :: * -> *) g a.
(MonadIO m, MonadCatch m, RandomGen g) =>
Logger -> g -> m a -> m a
retryOnSqliteBusy Logger
logger 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 <-  IO String -> (String -> IO String) -> Maybe String -> IO String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO String
IO.getCurrentDirectory String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
argsProjectRoot
          String
dbLoc <- String -> IO String
getHieDbLoc String
root
          Logger -> String -> (WithHieDb -> IndexQueue -> IO ()) -> IO ()
runWithDb Logger
logger String
dbLoc ((WithHieDb -> IndexQueue -> IO ()) -> IO ())
-> (WithHieDb -> IndexQueue -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \WithHieDb
hiedb IndexQueue
hieChan -> do
            VFSHandle
vfs <- IO VFSHandle
makeVFSHandle
            Action IdeGhcSession
sessionLoader <- SessionLoadingOptions -> String -> IO (Action IdeGhcSession)
loadSessionWithOptions SessionLoadingOptions
argsSessionLoadingOptions String
"."
            let def_options :: IdeOptions
def_options = Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions Config
argsDefaultHlsConfig Action IdeGhcSession
sessionLoader
                options :: IdeOptions
options = IdeOptions
def_options
                    { optCheckParents :: IO CheckParents
optCheckParents = CheckParents -> IO CheckParents
forall (f :: * -> *) a. Applicative f => a -> f a
pure CheckParents
NeverCheck
                    , optCheckProject :: IO Bool
optCheckProject = Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
                    , optModifyDynFlags :: Config -> DynFlagsModifications
optModifyDynFlags = IdeOptions -> Config -> DynFlagsModifications
optModifyDynFlags IdeOptions
def_options (Config -> DynFlagsModifications)
-> (Config -> DynFlagsModifications)
-> Config
-> DynFlagsModifications
forall a. Semigroup a => a -> a -> a
<> Plugin Config -> Config -> DynFlagsModifications
forall c. Plugin c -> c -> DynFlagsModifications
pluginModifyDynflags Plugin Config
plugins
                    }
            IdeState
ide <- Config
-> Rules ()
-> Maybe (LanguageContextEnv Config)
-> Logger
-> Debouncer NormalizedUri
-> IdeOptions
-> VFSHandle
-> WithHieDb
-> IndexQueue
-> IO IdeState
initialise Config
argsDefaultHlsConfig Rules ()
rules Maybe (LanguageContextEnv Config)
forall a. Maybe a
Nothing Logger
logger Debouncer NormalizedUri
debouncer IdeOptions
options VFSHandle
vfs WithHieDb
hiedb IndexQueue
hieChan
            IdeState -> IO ()
shakeSessionInit 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

{-# ANN defaultMain ("HLint: ignore Use nubOrd" :: String) #-}


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 (m :: * -> *) a. Monad m => a -> m a
return [String
x]
        else do
            let recurse :: String -> Bool
recurse String
"." = Bool
True
                recurse String
x | String
"." String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` ShowS
takeFileName String
x = Bool
False -- skip .git etc
                recurse String
x = ShowS
takeFileName String
x String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String
"dist", String
"dist-newstyle"] -- cabal directories
            [String]
files <- (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (\String
x -> ShowS
takeExtension String
x String -> [String] -> 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 (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 (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
files) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                String -> IO ()
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 (m :: * -> *) a. Monad m => a -> m a
return [String]
files