-- 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 ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}

module Ide.Main(defaultMain, runLspMode) where

import           Control.Monad.Extra
import qualified Data.Aeson.Encode.Pretty      as A
import qualified Data.ByteString.Lazy.Char8    as LBS
import           Data.Default
import qualified Data.Text                     as T
import           Development.IDE.Core.Rules
import           Development.IDE.Main          (isLSP)
import qualified Development.IDE.Main          as Main
import           Development.IDE.Types.Logger  as G
import qualified Development.IDE.Types.Options as Ghcide
import           Development.Shake             (ShakeOptions (shakeThreads))
import           Ide.Arguments
import           Ide.Logger
import           Ide.Plugin.ConfigUtils        (pluginsToDefaultConfig,
                                                pluginsToVSCodeExtensionSchema)
import           Ide.Types                     (IdePlugins, ipMap)
import           Ide.Version
import qualified Language.LSP.Server           as LSP
import qualified System.Directory.Extra        as IO
import           System.IO
import qualified System.Log.Logger             as L

defaultMain :: Arguments -> IdePlugins IdeState -> IO ()
defaultMain :: Arguments -> IdePlugins IdeState -> IO ()
defaultMain 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

        Ghcide GhcideArguments
ghcideArgs -> do
            {- see WARNING above -}
            Handle -> String -> IO ()
hPutStrLn Handle
stderr String
hlsVer
            GhcideArguments -> IdePlugins IdeState -> IO ()
runLspMode GhcideArguments
ghcideArgs IdePlugins IdeState
idePlugins

        Arguments
VSCodeExtensionSchemaMode -> do
          ByteString -> IO ()
LBS.putStrLn (ByteString -> IO ()) -> ByteString -> IO ()
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
idePlugins

        Arguments
DefaultConfigurationMode -> do
          ByteString -> IO ()
LBS.putStrLn (ByteString -> IO ()) -> ByteString -> IO ()
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
idePlugins

-- ---------------------------------------------------------------------

hlsLogger :: G.Logger
hlsLogger :: Logger
hlsLogger = (Priority -> Text -> IO ()) -> Logger
G.Logger ((Priority -> Text -> IO ()) -> Logger)
-> (Priority -> Text -> IO ()) -> Logger
forall a b. (a -> b) -> a -> b
$ \Priority
pri Text
txt ->
    case Priority
pri of
      Priority
G.Telemetry -> String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
logm     (Text -> String
T.unpack Text
txt)
      Priority
G.Debug     -> String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
debugm   (Text -> String
T.unpack Text
txt)
      Priority
G.Info      -> String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
logm     (Text -> String
T.unpack Text
txt)
      Priority
G.Warning   -> String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
warningm (Text -> String
T.unpack Text
txt)
      Priority
G.Error     -> String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
errorm   (Text -> String
T.unpack Text
txt)

-- ---------------------------------------------------------------------

runLspMode :: GhcideArguments -> IdePlugins IdeState -> IO ()
runLspMode :: GhcideArguments -> IdePlugins IdeState -> IO ()
runLspMode ghcideArgs :: GhcideArguments
ghcideArgs@GhcideArguments{Bool
Int
Maybe String
Command
argsProjectGhcVersion :: GhcideArguments -> Bool
argsThreads :: GhcideArguments -> Int
argsLogFile :: GhcideArguments -> Maybe String
argsDebugOn :: GhcideArguments -> Bool
argsExamplePlugin :: GhcideArguments -> Bool
argsTesting :: GhcideArguments -> Bool
argsShakeProfiling :: GhcideArguments -> Maybe String
argsCwd :: GhcideArguments -> Maybe String
argsCommand :: GhcideArguments -> Command
argsProjectGhcVersion :: Bool
argsThreads :: Int
argsLogFile :: Maybe String
argsDebugOn :: Bool
argsExamplePlugin :: Bool
argsTesting :: Bool
argsShakeProfiling :: Maybe String
argsCwd :: Maybe String
argsCommand :: Command
..} IdePlugins IdeState
idePlugins = do
    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
    Maybe String -> [String] -> Priority -> IO ()
LSP.setupLogger Maybe String
argsLogFile [String
"hls", String
"hie-bios"]
      (Priority -> IO ()) -> Priority -> IO ()
forall a b. (a -> b) -> a -> b
$ if Bool
argsDebugOn then Priority
L.DEBUG else Priority
L.INFO

    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
        Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"Starting (haskell-language-server)LSP server..."
        Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"  with arguments: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> GhcideArguments -> String
forall a. Show a => a -> String
show GhcideArguments
ghcideArgs
        Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"  with plugins: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [PluginId] -> String
forall a. Show a => a -> String
show (((PluginId, PluginDescriptor IdeState) -> PluginId)
-> [(PluginId, PluginDescriptor IdeState)] -> [PluginId]
forall a b. (a -> b) -> [a] -> [b]
map (PluginId, PluginDescriptor IdeState) -> PluginId
forall a b. (a, b) -> a
fst ([(PluginId, PluginDescriptor IdeState)] -> [PluginId])
-> [(PluginId, PluginDescriptor IdeState)] -> [PluginId]
forall a b. (a -> b) -> a -> b
$ IdePlugins IdeState -> [(PluginId, PluginDescriptor IdeState)]
forall ideState.
IdePlugins ideState -> [(PluginId, PluginDescriptor ideState)]
ipMap IdePlugins IdeState
idePlugins)
        Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"  in directory: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
dir

    Arguments -> IO ()
Main.defaultMain Arguments
forall a. Default a => a
def
      { argCommand :: Command
Main.argCommand = Command
argsCommand
      , argsHlsPlugins :: IdePlugins IdeState
Main.argsHlsPlugins = IdePlugins IdeState
idePlugins
      , argsLogger :: IO Logger
Main.argsLogger = Logger -> IO Logger
forall (f :: * -> *) a. Applicative f => a -> f a
pure Logger
hlsLogger
      , argsIdeOptions :: Config -> Action IdeGhcSession -> IdeOptions
Main.argsIdeOptions = \Config
_config Action IdeGhcSession
sessionLoader ->
        let defOptions :: IdeOptions
defOptions = Action IdeGhcSession -> IdeOptions
Ghcide.defaultIdeOptions Action IdeGhcSession
sessionLoader
        in IdeOptions
defOptions
            { optShakeProfiling :: Maybe String
Ghcide.optShakeProfiling = Maybe String
argsShakeProfiling
            , optTesting :: IdeTesting
Ghcide.optTesting = Bool -> IdeTesting
Ghcide.IdeTesting Bool
argsTesting
            , optShakeOptions :: ShakeOptions
Ghcide.optShakeOptions = (IdeOptions -> ShakeOptions
Ghcide.optShakeOptions IdeOptions
defOptions)
                {shakeThreads :: Int
shakeThreads = Int
argsThreads}
            }
      }