-- Copyright (c) 2019 The DAML Authors. All rights reserved.

-- SPDX-License-Identifier: Apache-2.0

{-# LANGUAGE CPP #-} -- To get precise GHC version

{-# 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.Map.Strict as Map
import qualified Data.Text as T
import Development.IDE.Core.Rules
import Development.IDE.Session (setInitialDynFlags, getHieDbLoc)
import Development.IDE.Types.Logger as G
import qualified Language.LSP.Server as LSP
import Ide.Arguments
import Ide.Logger
import Ide.Version
import Ide.Types (IdePlugins, ipMap)
import qualified System.Directory.Extra as IO
import System.Exit
import System.IO
import qualified System.Log.Logger as L
import HieDb.Run
import qualified Development.IDE.Main as Main
import qualified Development.IDE.Types.Options as Ghcide
import Development.Shake (ShakeOptions(shakeThreads))
import Data.Default

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

        DbCmd Options
opts Command
cmd -> do
          String
dir <- IO String
IO.getCurrentDirectory
          String
dbLoc <- String -> IO String
getHieDbLoc String
dir
          Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Using hiedb at: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dbLoc
          Maybe LibDir
mlibdir <- SessionLoadingOptions -> IO (Maybe LibDir)
setInitialDynFlags SessionLoadingOptions
forall a. Default a => a
def
          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 ->
              LibDir -> Options -> Command -> IO ()
runCommand LibDir
libdir Options
opts{database :: String
database = String
dbLoc} Command
cmd

        LspMode LspArguments
lspArgs -> do
            {- see WARNING above -}
            Handle -> String -> IO ()
hPutStrLn Handle
stderr String
hlsVer
            LspArguments -> IdePlugins IdeState -> IO ()
runLspMode LspArguments
lspArgs 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 :: LspArguments -> IdePlugins IdeState -> IO ()
runLspMode :: LspArguments -> IdePlugins IdeState -> IO ()
runLspMode lspArgs :: LspArguments
lspArgs@LspArguments{Bool
Int
[String]
Maybe String
argsProjectGhcVersion :: LspArguments -> Bool
argsThreads :: LspArguments -> Int
argsLogFile :: LspArguments -> Maybe String
argsDebugOn :: LspArguments -> Bool
argsExamplePlugin :: LspArguments -> Bool
argsTesting :: LspArguments -> Bool
argsShakeProfiling :: LspArguments -> Maybe String
argFiles :: LspArguments -> [String]
argsCwd :: LspArguments -> Maybe String
argLSP :: LspArguments -> Bool
argsProjectGhcVersion :: Bool
argsThreads :: Int
argsLogFile :: Maybe String
argsDebugOn :: Bool
argsExamplePlugin :: Bool
argsTesting :: Bool
argsShakeProfiling :: Maybe String
argFiles :: [String]
argsCwd :: Maybe String
argLSP :: Bool
..} 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 Bool
argLSP (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
<> LspArguments -> String
forall a. Show a => a -> String
show LspArguments
lspArgs
        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 (Map PluginId (PluginDescriptor IdeState) -> [PluginId]
forall k a. Map k a -> [k]
Map.keys (Map PluginId (PluginDescriptor IdeState) -> [PluginId])
-> Map PluginId (PluginDescriptor IdeState) -> [PluginId]
forall a b. (a -> b) -> a -> b
$ IdePlugins IdeState -> Map PluginId (PluginDescriptor IdeState)
forall ideState.
IdePlugins ideState -> Map 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
        Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"

    Arguments -> IO ()
Main.defaultMain Arguments
forall a. Default a => a
def
      { argFiles :: Maybe [String]
Main.argFiles = if Bool
argLSP then Maybe [String]
forall a. Maybe a
Nothing else [String] -> Maybe [String]
forall a. a -> Maybe a
Just []
      , argsHlsPlugins :: IdePlugins IdeState
Main.argsHlsPlugins = IdePlugins IdeState
idePlugins
      , argsLogger :: Logger
Main.argsLogger = Logger
hlsLogger
      , argsIdeOptions :: Maybe Config -> Action IdeGhcSession -> IdeOptions
Main.argsIdeOptions = \Maybe 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}
            }
      }