-- Copyright (c) 2019 The DAML Authors. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0
{-# LANGUAGE CPP               #-}
{-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# 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.Function                 ((&))
import           Data.List                     (sortOn)
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  (withTelemetryRecorder)
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 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),
                                                describePlugin, ipMap, pluginId)
import           Ide.Version
import           Prettyprinter                 as PP
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
  | LogSession Session.Log
  | LogOther T.Text
  deriving Int -> Log -> ShowS
[Log] -> ShowS
Log -> String
(Int -> Log -> ShowS)
-> (Log -> String) -> ([Log] -> ShowS) -> Show Log
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Log -> ShowS
showsPrec :: Int -> Log -> ShowS
$cshow :: Log -> String
show :: Log -> String
$cshowList :: [Log] -> ShowS
showList :: [Log] -> ShowS
Show

instance Pretty Log where
  pretty :: forall ann. Log -> Doc ann
pretty Log
log = case Log
log of
    LogVersion String
version -> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
version
    LogDirectory String
path -> Doc ann
"Directory:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
path
    LogLspStart GhcideArguments
ghcideArgs [PluginId]
pluginIds ->
      Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
        [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
          [ Doc ann
"Starting (haskell-language-server) LSP server..."
          , GhcideArguments -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow GhcideArguments
ghcideArgs
          , Doc ann
"PluginIds:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Text] -> Doc ann
forall ann. [Text] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (forall a b. Coercible a b => a -> b
forall a b. Coercible a b => a -> b
coerce @_ @[Text] [PluginId]
pluginIds) ]
    LogIDEMain Log
iDEMainLog -> Log -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Log -> Doc ann
pretty Log
iDEMainLog
    LogHieBios Log
hieBiosLog -> Log -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Log -> Doc ann
pretty Log
hieBiosLog
    LogSession Log
sessionLog -> Log -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Log -> Doc ann
pretty Log
sessionLog
    LogOther Text
t -> Text -> Doc ann
forall ann. Text -> Doc ann
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
    -- WARNING: If you write to stdout before runLanguageServer
    --          then the language server will not work

    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 (String -> IO ()) -> String -> IO ()
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 pluginSummary :: Doc Any
pluginSummary =
                  [Doc Any] -> Doc Any
forall ann. [Doc ann] -> Doc ann
PP.vsep
                    ([Doc Any] -> Doc Any) -> [Doc Any] -> Doc Any
forall a b. (a -> b) -> a -> b
$ (PluginDescriptor IdeState -> Doc Any)
-> [PluginDescriptor IdeState] -> [Doc Any]
forall a b. (a -> b) -> [a] -> [b]
map PluginDescriptor IdeState -> Doc Any
forall c ann. PluginDescriptor c -> Doc ann
describePlugin
                    ([PluginDescriptor IdeState] -> [Doc Any])
-> [PluginDescriptor IdeState] -> [Doc Any]
forall a b. (a -> b) -> a -> b
$ (PluginDescriptor IdeState -> PluginId)
-> [PluginDescriptor IdeState] -> [PluginDescriptor IdeState]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn PluginDescriptor IdeState -> PluginId
forall ideState. PluginDescriptor ideState -> PluginId
pluginId
                    ([PluginDescriptor IdeState] -> [PluginDescriptor IdeState])
-> [PluginDescriptor IdeState] -> [PluginDescriptor IdeState]
forall a b. (a -> b) -> a -> b
$ IdePlugins IdeState -> [PluginDescriptor IdeState]
forall ideState. IdePlugins ideState -> [PluginDescriptor ideState]
ipMap IdePlugins IdeState
idePlugins
            String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc Any -> String
forall a. Show a => a -> String
show Doc Any
pluginSummary

        BiosMode BiosAction
PrintCradleType -> do
            String
dir <- IO String
IO.getCurrentDirectory
            Maybe String
hieYaml <- SessionLoadingOptions -> String -> IO (Maybe String)
Session.findCradle SessionLoadingOptions
forall a. Default a => a
def (String
dir String -> ShowS
</> String
"a")
            Cradle Void
cradle <- SessionLoadingOptions
-> Recorder (WithPriority Log)
-> Maybe String
-> String
-> IO (Cradle Void)
Session.loadCradle SessionLoadingOptions
forall a. Default a => a
def ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogSession Recorder (WithPriority Log)
recorder) Maybe String
hieYaml String
dir
            Cradle Void -> IO ()
forall a. Show a => a -> IO ()
print Cradle Void
cradle

        Ghcide GhcideArguments
ghcideArgs -> do
            {- see WARNING above -}
            Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder Priority
Info (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ 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 (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
encodePrettySorted (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ IdePlugins IdeState -> Value
forall a. IdePlugins a -> Value
pluginsToVSCodeExtensionSchema IdePlugins IdeState
idePlugins
        Arguments
DefaultConfigurationMode -> do
          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
encodePrettySorted (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ IdePlugins IdeState -> Value
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 SessionLoadingOptions
forall a. Default a => a
def String
initialFp
          Cradle Void
cradle <- SessionLoadingOptions
-> Recorder (WithPriority Log)
-> Maybe String
-> String
-> IO (Cradle Void)
Session.loadCradle SessionLoadingOptions
forall a. Default a => a
def ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogSession Recorder (WithPriority Log)
recorder) Maybe String
hieYaml String
d
          (CradleSuccess String
libdir) <- Cradle Void -> IO (CradleLoadResult String)
forall a. Cradle a -> IO (CradleLoadResult String)
HieBios.getRuntimeGhcLibDir Cradle Void
cradle
          String -> IO ()
putStr String
libdir
  where
    encodePrettySorted :: Value -> ByteString
encodePrettySorted = Config -> Value -> ByteString
forall a. ToJSON a => Config -> a -> ByteString
A.encodePretty' Config
A.defConfig
      { A.confCompare = 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
Priority
Command
argsCommand :: Command
argsCwd :: Maybe String
argsShakeProfiling :: Maybe String
argsTesting :: Bool
argsExamplePlugin :: Bool
argsLogLevel :: Priority
argsLogFile :: Maybe String
argsLogStderr :: Bool
argsLogClient :: Bool
argsThreads :: Int
argsProjectGhcVersion :: Bool
argsCommand :: GhcideArguments -> Command
argsCwd :: GhcideArguments -> Maybe String
argsShakeProfiling :: GhcideArguments -> Maybe String
argsTesting :: GhcideArguments -> Bool
argsExamplePlugin :: GhcideArguments -> Bool
argsLogLevel :: GhcideArguments -> Priority
argsLogFile :: GhcideArguments -> Maybe String
argsLogStderr :: GhcideArguments -> Bool
argsLogClient :: GhcideArguments -> Bool
argsThreads :: GhcideArguments -> Int
argsProjectGhcVersion :: GhcideArguments -> Bool
..} IdePlugins IdeState
idePlugins = (Recorder (WithPriority (Doc Any)) -> IO ()) -> IO ()
forall (m :: * -> *) a c.
(MonadIO m, MonadMask m) =>
(Recorder (WithPriority (Doc a)) -> m c) -> m c
withTelemetryRecorder ((Recorder (WithPriority (Doc Any)) -> IO ()) -> IO ())
-> (Recorder (WithPriority (Doc Any)) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Recorder (WithPriority (Doc Any))
telemetryRecorder' -> do
    let log :: Priority -> Log -> IO ()
log = Recorder (WithPriority Log) -> Priority -> Log -> IO ()
forall (m :: * -> *) msg.
(HasCallStack, MonadIO m) =>
Recorder (WithPriority msg) -> Priority -> msg -> m ()
logWith Recorder (WithPriority Log)
recorder
    Maybe String -> (String -> IO ()) -> IO ()
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 (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Log
LogDirectory String
dir

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Command -> Bool
isLSP Command
argsCommand) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Priority -> Log -> IO ()
log Priority
Info (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ GhcideArguments -> [PluginId] -> Log
LogLspStart GhcideArguments
ghcideArgs ((PluginDescriptor IdeState -> PluginId)
-> [PluginDescriptor IdeState] -> [PluginId]
forall a b. (a -> b) -> [a] -> [b]
map PluginDescriptor IdeState -> PluginId
forall ideState. PluginDescriptor ideState -> PluginId
pluginId ([PluginDescriptor IdeState] -> [PluginId])
-> [PluginDescriptor IdeState] -> [PluginId]
forall a b. (a -> b) -> a -> b
$ IdePlugins IdeState -> [PluginDescriptor IdeState]
forall ideState. IdePlugins ideState -> [PluginDescriptor ideState]
ipMap IdePlugins IdeState
idePlugins)

    let args :: Arguments
args = (if Bool
argsTesting then Recorder (WithPriority Log)
-> String -> IdePlugins IdeState -> Arguments
IDEMain.testing else Recorder (WithPriority Log)
-> String -> IdePlugins IdeState -> Arguments
IDEMain.defaultArguments)
                    ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogIDEMain Recorder (WithPriority Log)
recorder) String
dir IdePlugins IdeState
idePlugins

    let telemetryRecorder :: Recorder (WithPriority Log)
telemetryRecorder = Recorder (WithPriority (Doc Any))
telemetryRecorder' Recorder (WithPriority (Doc Any))
-> (Recorder (WithPriority (Doc Any))
    -> Recorder (WithPriority Log))
-> Recorder (WithPriority Log)
forall a b. a -> (a -> b) -> b
& (Log -> Doc Any)
-> Recorder (WithPriority (Doc Any)) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Doc Any
forall a ann. Pretty a => a -> Doc ann
forall ann. Log -> Doc ann
pretty

    Recorder (WithPriority Log) -> Arguments -> IO ()
IDEMain.defaultMain ((Log -> Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b.
(a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)
cmapWithPrio Log -> Log
LogIDEMain (Recorder (WithPriority Log) -> Recorder (WithPriority Log))
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a b. (a -> b) -> a -> b
$ Recorder (WithPriority Log)
recorder Recorder (WithPriority Log)
-> Recorder (WithPriority Log) -> Recorder (WithPriority Log)
forall a. Semigroup a => a -> a -> a
<> Recorder (WithPriority Log)
telemetryRecorder) Arguments
args
      { IDEMain.argCommand = argsCommand
      , IDEMain.argsThreads = if argsThreads == 0 then Nothing else Just $ fromIntegral argsThreads
      , 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 { Ghcide.optShakeProfiling = argsShakeProfiling }
      }