{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -Wno-dodgy-imports #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Ide.Main(defaultMain, runLspMode, Log(..)) where
import Control.Monad.Extra
import qualified Data.Aeson.Encode.Pretty as A
import Data.Coerce (coerce)
import Data.Default
import Data.List (sort)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Lazy.Encoding (decodeUtf8)
import qualified Data.Text.Lazy.IO as LT
import Development.IDE.Core.Rules hiding (Log, logToPriority)
import Development.IDE.Core.Tracing (withTelemetryLogger)
import Development.IDE.Main (isLSP)
import qualified Development.IDE.Main as IDEMain
import qualified Development.IDE.Session as Session
import qualified Development.IDE.Types.Options as Ghcide
import GHC.Stack (emptyCallStack)
import qualified HIE.Bios.Environment as HieBios
import HIE.Bios.Types hiding (Log)
import qualified HIE.Bios.Types as HieBios
import Ide.Arguments
import Ide.Logger as G
import Ide.Plugin.ConfigUtils (pluginsToDefaultConfig,
pluginsToVSCodeExtensionSchema)
import Ide.Types (IdePlugins, PluginId (PluginId),
ipMap, pluginId)
import Ide.Version
import System.Directory
import qualified System.Directory.Extra as IO
import System.FilePath
data Log
= LogVersion !String
| LogDirectory !FilePath
| LogLspStart !GhcideArguments ![PluginId]
| LogIDEMain IDEMain.Log
| LogHieBios HieBios.Log
| LogOther T.Text
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 Log
log = case Log
log of
LogVersion String
version -> forall a ann. Pretty a => a -> Doc ann
pretty String
version
LogDirectory String
path -> Doc ann
"Directory:" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty String
path
LogLspStart GhcideArguments
ghcideArgs [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 (haskell-language-server) LSP server..."
, forall a ann. Show a => a -> Doc ann
viaShow GhcideArguments
ghcideArgs
, 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 @_ @[Text] [PluginId]
pluginIds) ]
LogIDEMain Log
iDEMainLog -> forall a ann. Pretty a => a -> Doc ann
pretty Log
iDEMainLog
LogHieBios Log
hieBiosLog -> forall a ann. Pretty a => a -> Doc ann
pretty Log
hieBiosLog
LogOther Text
t -> forall a ann. Pretty a => a -> Doc ann
pretty Text
t
defaultMain :: Recorder (WithPriority Log) -> Arguments -> IdePlugins IdeState -> IO ()
defaultMain :: Recorder (WithPriority Log)
-> Arguments -> IdePlugins IdeState -> IO ()
defaultMain Recorder (WithPriority Log)
recorder Arguments
args IdePlugins IdeState
idePlugins = do
String
hlsVer <- IO String
haskellLanguageServerVersion
case Arguments
args of
Arguments
ProbeToolsMode -> do
ProgramsOfInterest
programsOfInterest <- IO ProgramsOfInterest
findProgramVersions
String -> IO ()
putStrLn String
hlsVer
String -> IO ()
putStrLn String
"Tool versions found on the $PATH"
String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ ProgramsOfInterest -> String
showProgramVersionOfInterest ProgramsOfInterest
programsOfInterest
VersionMode PrintVersion
PrintVersion ->
String -> IO ()
putStrLn String
hlsVer
VersionMode PrintVersion
PrintNumericVersion ->
String -> IO ()
putStrLn String
haskellLanguageServerNumericVersion
Arguments
ListPluginsMode -> do
let pluginNames :: [String]
pluginNames = forall a. Ord a => [a] -> [a]
sort
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ((\(PluginId Text
t) -> Text -> String
T.unpack Text
t) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ideState. PluginDescriptor ideState -> PluginId
pluginId)
forall a b. (a -> b) -> a -> b
$ forall ideState. IdePlugins ideState -> [PluginDescriptor ideState]
ipMap IdePlugins IdeState
idePlugins
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
putStrLn [String]
pluginNames
BiosMode BiosAction
PrintCradleType -> do
String
dir <- IO String
IO.getCurrentDirectory
Maybe String
hieYaml <- SessionLoadingOptions -> String -> IO (Maybe String)
Session.findCradle forall a. Default a => a
def String
dir
Cradle Void
cradle <- SessionLoadingOptions -> Maybe String -> String -> IO (Cradle Void)
Session.loadCradle forall a. Default a => a
def Maybe String
hieYaml String
dir
forall a. Show a => a -> IO ()
print Cradle Void
cradle
Ghcide GhcideArguments
ghcideArgs -> do
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
$ String -> Log
LogVersion String
hlsVer
Recorder (WithPriority Log)
-> GhcideArguments -> IdePlugins IdeState -> IO ()
runLspMode Recorder (WithPriority Log)
recorder GhcideArguments
ghcideArgs IdePlugins IdeState
idePlugins
Arguments
VSCodeExtensionSchemaMode -> do
Text -> IO ()
LT.putStrLn forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8 forall a b. (a -> b) -> a -> b
$ Value -> ByteString
encodePrettySorted forall a b. (a -> b) -> a -> b
$ forall a. IdePlugins a -> Value
pluginsToVSCodeExtensionSchema IdePlugins IdeState
idePlugins
Arguments
DefaultConfigurationMode -> do
Text -> IO ()
LT.putStrLn forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8 forall a b. (a -> b) -> a -> b
$ Value -> ByteString
encodePrettySorted forall a b. (a -> b) -> a -> b
$ forall a. IdePlugins a -> Value
pluginsToDefaultConfig IdePlugins IdeState
idePlugins
Arguments
PrintLibDir -> do
String
d <- IO String
getCurrentDirectory
let initialFp :: String
initialFp = String
d String -> ShowS
</> String
"a"
Maybe String
hieYaml <- SessionLoadingOptions -> String -> IO (Maybe String)
Session.findCradle forall a. Default a => a
def String
initialFp
Cradle Void
cradle <- SessionLoadingOptions -> Maybe String -> String -> IO (Cradle Void)
Session.loadCradle forall a. Default a => a
def Maybe String
hieYaml String
d
(CradleSuccess String
libdir) <- forall a.
LogAction IO (WithSeverity Log)
-> Cradle a -> IO (CradleLoadResult String)
HieBios.getRuntimeGhcLibDir (forall (m :: * -> *) msg.
(MonadIO m, HasCallStack) =>
Recorder (WithPriority msg) -> LogAction m (WithSeverity msg)
toCologActionWithPrio (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogHieBios Recorder (WithPriority Log)
recorder)) Cradle Void
cradle
String -> IO ()
putStr String
libdir
where
encodePrettySorted :: Value -> ByteString
encodePrettySorted = forall a. ToJSON a => Config -> a -> ByteString
A.encodePretty' Config
A.defConfig
{ confCompare :: Text -> Text -> Ordering
A.confCompare = forall a. Ord a => a -> a -> Ordering
compare
}
runLspMode :: Recorder (WithPriority Log) -> GhcideArguments -> IdePlugins IdeState -> IO ()
runLspMode :: Recorder (WithPriority Log)
-> GhcideArguments -> IdePlugins IdeState -> IO ()
runLspMode Recorder (WithPriority Log)
recorder ghcideArgs :: GhcideArguments
ghcideArgs@GhcideArguments{Bool
Int
Maybe String
Command
Priority
argsProjectGhcVersion :: GhcideArguments -> Bool
argsThreads :: GhcideArguments -> Int
argsLogClient :: GhcideArguments -> Bool
argsLogStderr :: GhcideArguments -> Bool
argsLogFile :: GhcideArguments -> Maybe String
argsLogLevel :: GhcideArguments -> Priority
argsExamplePlugin :: GhcideArguments -> Bool
argsTesting :: GhcideArguments -> Bool
argsShakeProfiling :: GhcideArguments -> Maybe String
argsCwd :: GhcideArguments -> Maybe String
argsCommand :: GhcideArguments -> Command
argsProjectGhcVersion :: Bool
argsThreads :: Int
argsLogClient :: Bool
argsLogStderr :: Bool
argsLogFile :: Maybe String
argsLogLevel :: Priority
argsExamplePlugin :: Bool
argsTesting :: Bool
argsShakeProfiling :: Maybe String
argsCwd :: Maybe String
argsCommand :: Command
..} IdePlugins IdeState
idePlugins = forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
(Logger -> m a) -> m a
withTelemetryLogger forall a b. (a -> b) -> a -> b
$ \Logger
telemetryLogger -> do
let log :: Priority -> Log -> IO ()
log = forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe String
argsCwd String -> IO ()
IO.setCurrentDirectory
String
dir <- IO String
IO.getCurrentDirectory
Priority -> Log -> IO ()
log Priority
Info forall a b. (a -> b) -> a -> b
$ String -> Log
LogDirectory String
dir
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Command -> Bool
isLSP Command
argsCommand) forall a b. (a -> b) -> a -> b
$ do
Priority -> Log -> IO ()
log Priority
Info forall a b. (a -> b) -> a -> b
$ GhcideArguments -> [PluginId] -> Log
LogLspStart GhcideArguments
ghcideArgs (forall a b. (a -> b) -> [a] -> [b]
map forall ideState. PluginDescriptor ideState -> PluginId
pluginId forall a b. (a -> b) -> a -> b
$ forall ideState. IdePlugins ideState -> [PluginDescriptor ideState]
ipMap IdePlugins IdeState
idePlugins)
let logger :: Logger
logger = (Priority -> Text -> IO ()) -> Logger
Logger forall a b. (a -> b) -> a -> b
$ \Priority
p Text
m -> forall msg.
Recorder msg -> forall (m :: * -> *). MonadIO m => msg -> m ()
logger_ Recorder (WithPriority Log)
recorder (forall a. Priority -> CallStack -> a -> WithPriority a
WithPriority Priority
p CallStack
emptyCallStack forall a b. (a -> b) -> a -> b
$ Text -> Log
LogOther Text
m)
args :: Arguments
args = (if Bool
argsTesting then Recorder (WithPriority Log)
-> Logger -> IdePlugins IdeState -> Arguments
IDEMain.testing else Recorder (WithPriority Log)
-> Logger -> IdePlugins IdeState -> Arguments
IDEMain.defaultArguments)
(forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogIDEMain Recorder (WithPriority Log)
recorder) Logger
logger IdePlugins IdeState
idePlugins
Recorder (WithPriority Log) -> Arguments -> IO ()
IDEMain.defaultMain (forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogIDEMain Recorder (WithPriority Log)
recorder) Arguments
args
{ argCommand :: Command
IDEMain.argCommand = Command
argsCommand
, argsLogger :: IO Logger
IDEMain.argsLogger = forall (f :: * -> *) a. Applicative f => a -> f a
pure Logger
logger forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. Applicative f => a -> f a
pure Logger
telemetryLogger
, argsThreads :: Maybe Natural
IDEMain.argsThreads = if Int
argsThreads forall a. Eq a => a -> a -> Bool
== Int
0 then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
argsThreads
, argsIdeOptions :: Config -> Action IdeGhcSession -> IdeOptions
IDEMain.argsIdeOptions = \Config
config Action IdeGhcSession
sessionLoader ->
let defOptions :: IdeOptions
defOptions = Arguments -> Config -> Action IdeGhcSession -> IdeOptions
IDEMain.argsIdeOptions Arguments
args Config
config Action IdeGhcSession
sessionLoader
in IdeOptions
defOptions { optShakeProfiling :: Maybe String
Ghcide.optShakeProfiling = Maybe String
argsShakeProfiling }
}